!
!  $Author: pkubota $
!  $Date: 2011/05/27 23:15:12 $
!  $Revision: 1.3 $
!
!     ------------------------------------------------------------------
!     Module to set the precision of REAL variables
!     ------------------------------------------------------------------
MODULE realtype_rd
  INTEGER, parameter :: RealK=selected_real_kind(15, 307)
END MODULE realtype_rd
!+ Module setting sizes of spectral arrays.
!
MODULE dimensions_spec_ucf
!
!
! Description:
!
! This module contains the default sizes for spectral arrays. In the
! course of time it should become redundant.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  INTEGER, Parameter :: npd_band = 9
!           Number of spectral bands
  INTEGER, Parameter :: npd_exclude = 2
!           Numer of excluded bands
  INTEGER, Parameter :: npd_k_term = 25
!           Number of esft terms
  INTEGER, Parameter :: npd_type = 20
!           Number of data types
  INTEGER, Parameter :: npd_species = 11
!           Number of gaseous species
  INTEGER, Parameter :: npd_scale_variable = 4
!           Number of scaling variables
  INTEGER, Parameter :: npd_surface = 10
!           Number of surface types
  INTEGER, Parameter :: npd_brdf_basis_fnc = 2
!           Number of BRDF basis functions
  INTEGER, Parameter :: npd_brdf_trunc = 5
!           Order of BRDF truncation
  INTEGER, Parameter :: npd_continuum = 3
!           Number of continua
  INTEGER, Parameter :: npd_albedo_parm = 4
!           Number of albedo parameters  
  INTEGER, Parameter :: npd_drop_type = 6
!           Number of drop types
  INTEGER, Parameter :: npd_ice_type = 10
!           Number of ice crystal types
  INTEGER, Parameter :: npd_aerosol_species = 13
!           Number of aerosol species
  INTEGER, Parameter :: npd_thermal_coeff = 9
!           Number of thermal coefficients
  INTEGER, Parameter :: npd_fit_temp = 5001
!           Number of temperature datapoints
  INTEGER, Parameter :: npd_cloud_parameter = 501
!           Number of cloud parameters
  INTEGER, Parameter :: npd_humidities = 21
!           Number of humidities
  INTEGER, Parameter :: npd_phase_term = 501
!           Number of terms in the phase function
  INTEGER, Parameter :: npd_channel = 2
!           Number of spectral channels permitted for output
!
END MODULE dimensions_spec_ucf
!+ Module to set indices of aerosol components.
!
MODULE aerosol_component_pcf
!
!
  INTEGER, Parameter :: npd_aerosol_component = 25
!   Size allocated for identifiers for aerosols.
!
! SRA Climatological Aerosols:
  INTEGER, Parameter :: IP_water_soluble = 1
!   Water soluble aerosol
  INTEGER, Parameter :: IP_dust_like =2 
!   Dust-like aerosol
  INTEGER, Parameter :: IP_oceanic = 3
!   Oceanic aerosol
  INTEGER, Parameter :: IP_soot = 4
!   Soot aerosol
  INTEGER, Parameter :: IP_ash = 5
!   Volcanic ash
  INTEGER, Parameter :: IP_sulphuric = 6
!   Sulphuric acid
!
  INTEGER, Parameter :: IP_ammonium_sulphate =7
!   Generic ammonium sulphate aerosol
!
  INTEGER, Parameter :: IP_aerosol_uncharacterized = 8
!   Uncharacterized aerosol (for observations)
!
  INTEGER, Parameter :: IP_saharan_dust = 9
!   Saharan dust
!
! Aerosols for the sulphur cycle in the Unified Model
  INTEGER, Parameter :: IP_accum_sulphate = 10
!   Accumulation mode sulphate
  INTEGER, Parameter :: IP_aitken_sulphate = 11
!   Aitken mode sulphate
!
! Aerosols for the standard soot model in the Unified Model
  INTEGER, Parameter :: IP_fresh_soot = 12
!   Fresh soot
  INTEGER, Parameter :: IP_aged_soot = 13
!   Aged soot
!
! Aerosols for sea-salt modelling:
  INTEGER, Parameter :: IP_sodium_chloride = 14
!   Sodium chloride (generic aerosol)
  INTEGER, Parameter :: IP_sodium_chloride_film = 15
!   Sodium chloride (film mode)
  INTEGER, Parameter :: IP_sodium_chloride_jet = 16
!   Sodium chloride (jet mode)
!
! Aerosols for the dust scheme within the Unified Model
  INTEGER, Parameter :: IP_dust_div1 = 17
!   Dust, division1
  INTEGER, Parameter :: IP_dust_div2 = 18
!   Dust, division2
  INTEGER, Parameter :: IP_dust_div3 = 19
!   Dust, division3
  INTEGER, Parameter :: IP_dust_div4 = 20
!   Dust, division4
  INTEGER, Parameter :: IP_dust_div5 = 21
!   Dust, division5
  INTEGER, Parameter :: IP_dust_div6 = 22
!   Dust, division6
!
! Miomass aerosols:
  INTEGER, Parameter :: IP_biomass_1 = 23
!   Biomass (division 1)
  INTEGER, Parameter :: IP_biomass_2 = 24
!   Biomass (division 2)
  INTEGER, Parameter :: IP_biogenic  = 25
!
  CHARACTER (LEN=20), Parameter :: &
    name_aerosol_component(npd_aerosol_component) = (/ &
                                     "Water soluble       ", &
                                     "Dust-like           ", &
                                     "Oceanic             ", &
                                     "Soot                ", &
                                     "Volcanic Ash        ", &
                                     "Sulphuric Acid      ", &
                                     "Ammonium Sulphate   ", &
                                     "Uncharacterized     ", &
                                     "Saharan Dust        ", &
                                     "Accum. Sulphate     ", &
                                     "Aitken Sulphate     ", &
                                     "Fresh Soot          ", &
                                     "Aged Soot           ", &
                                     "Generic NaCl        ", &
                                     "NaCl film mode      ", &
                                     "NaCl jet mode       ", &
                                     "Dust Division 1     ", &
                                     "Dust Division 2     ", &
                                     "Dust Division 3     ", &
                                     "Dust Division 4     ", &
                                     "Dust Division 5     ", &
                                     "Dust Division 6     ", &
                                     "Bimomass Division 1 ", &
                                     "Bimomass Division 2 ", &
                                     "Biogenic            "  &
                                    /)
!
END MODULE aerosol_component_pcf
!+ Module to set the parametrizations available for aerosols.
!
MODULE aerosol_parametrization_pcf
!
! Description:
!
!   This module defines the identifiers for parametrization schemes
!   available for aerosols.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
! Version       Date            Comment
! -------       ----            -------
! 2.0           14/08/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  INTEGER, Parameter :: IP_aerosol_param_dry       = 1
!   Parametrization for dry aerosols
  INTEGER, Parameter :: IP_aerosol_param_moist     = 2
!   Parametrization for moist aerosols
  INTEGER, Parameter :: IP_aerosol_unparametrized  = 3
!  Observational aerosol data
  INTEGER, Parameter :: IP_aerosol_param_phf_dry   = 4
!   Parametrization of the phase function for dry aerosols
  INTEGER, Parameter :: IP_aerosol_param_phf_moist = 5
!   Parametrization of the phase function for moist aerosols
!
END MODULE aerosol_parametrization_pcf
!+ Module to set types of angular integration
!
MODULE angular_integration_pcf
!
! Description:
!
!   This module defines the forms of angular integration
!   available within the radiation code.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_two_stream          = 1
!   Two-stream scheme
  INTEGER, Parameter :: IP_IR_Gauss            = 2
!   Gaussian integration in the IR
  INTEGER, Parameter :: IP_spherical_harmonic  = 3
!   Integration by spherical harmonics
!
!
!
END MODULE angular_integration_pcf
!+ Module to set components of clouds
!
MODULE cloud_component_pcf
!
! Description:
!
!
! Current Owner of the Code: J.-C. Thelen
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J.-C. Thelen)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of Header
!
!
!
  IMPLICIT NONE
!
!
   INTEGER, Parameter :: IP_clcmp_st_water  = 1
!           Stratiform water droplets   
   INTEGER, Parameter :: IP_clcmp_st_ice    = 2
!           Stratiform ice crystals   
   INTEGER, Parameter :: IP_clcmp_cnv_water = 3
!           Convective water droplets   
   INTEGER, Parameter :: IP_clcmp_cnv_ice   = 4
!           Convective ice crystals
!
!
!
END Module cloud_component_pcf
!+ Module to define parametrization schemes for water clouds.
!
MODULE cloud_parametrization_pcf
!
! Description:
!
!   This module defines the identifiers for different parametrization
!   schemes for water droplets.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
 INTEGER, Parameter ::  npd_cloud_fit = 5
!   Number of cloud fitting schemes
!
 INTEGER, Parameter :: IP_Slingo_Schrecker = 1
!   Parametrization of Slingo & Schrecker
 INTEGER, Parameter :: IP_Ackerman_Stephens = 2 
!   Parametrization of Ackerman & Stephens (1987) as extended
!   Hu and Stamnes (1993): i.e. a fit of the form a.r^b+c
!   is used for each single-scattering property:
!   Ackerman and Stephens considered only the coalbedo explicitly.
 INTEGER, Parameter :: IP_drop_unparametrized = 3
!   Unparametrized droplet data
 INTEGER, Parameter :: IP_drop_parametrization_test = 4
!   Test parametrization
 INTEGER, Parameter :: IP_drop_Pade_2 = 5
!   Pade approximation of the second order 
!   (third order for the extinction)
 INTEGER, Parameter :: IP_Slingo_Schr_PHF = 6
!   Parametrization of Slingo & Schrecker extended to higher moments
!   of the phase function
 INTEGER, Parameter :: IP_drop_Pade_2_PHF = 7
!   Pade approximation of the second order (third order for the 
!    extinction) extended to higher moments of the phase function
!
END MODULE cloud_parametrization_pcf
!+ Module to set regions of clouds
!
MODULE cloud_region_pcf
!
! Description:
!
!   This module defines the identifiers for different 
!   regions of clouds. Regions are defined for alcgorithmic
!   purposes and are aggaregations for different macroscopic
!   clouds, treated identically in radiation calculations.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_region_clear = 1
!   Reference number for clear-sky region
  INTEGER, Parameter :: IP_region_strat = 2
!   Reference number for stratiform cloudy region
  INTEGER, Parameter :: IP_region_conv  = 3
!   Reference number for convective cloudy region
!
!
!
END MODULE cloud_region_pcf
!+ Module to set representations of clouds
!
MODULE cloud_representation_pcf
!
! Description:
!
!   This module defines the identifiers for different 
!   representations of clouds, meaning the macroscopic
!   division of cloud in a single atmospheric layer.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_cloud_homogen    = 1
!       All components are mixed homogeneously
  INTEGER, Parameter :: IP_cloud_ice_water  = 2
!       Ice and water clouds are treated separately
  INTEGER, Parameter :: IP_cloud_conv_strat = 3
!       Clouds are divided into homogeneously mixed
!       stratiform and convective parts
  INTEGER, Parameter :: IP_cloud_csiw       = 4
!       Clouds divided into ice and water phases and
!       into stratiform and convective components.







!
!
!
END MODULE cloud_representation_pcf
!+ Module to set cloud schemes
!
MODULE cloud_scheme_pcf
!
! Description:
!
!   This module defines the identifiers for different 
!   cloud schemes within the radiation clode. A cloud
!   scheme in this context refers principally to a 
!   treatment of the vertical overlap between different
!   cloudy layers.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_cloud_mix_max         = 2
!   Maximum/random overlap in a mixed column
  INTEGER, Parameter :: IP_cloud_mix_random      = 4
!   Random overlap in a mixed column
  INTEGER, Parameter :: IP_cloud_column_max      = 3
!   Maximum overlap in a column model
  INTEGER, Parameter :: IP_cloud_clear           = 5
!   Clear column
  INTEGER, Parameter :: IP_cloud_triple          = 6
!   Mixed column with split between convective and layer cloud
  INTEGER, Parameter :: IP_cloud_part_corr       = 7
!   Coupled overlap with partial correlation of cloud
  INTEGER, Parameter :: IP_cloud_part_corr_cnv   = 8
!   Coupled overlap with partial correlation of cloud
!   with a separate treatment of convective cloud




!
!
!
END MODULE cloud_scheme_pcf
!+ Module to set types of clouds
!
MODULE cloud_type_pcf
!
! Description:
!
!   This module defines the idebtifiers for different types of
!   clouds, generally referring to what they consist of, or
!   how they were formed. Identifers can be reused if they
!   are never to be used simultaneously; so, for example, if
!   cloud is divided simply into convective and stratiform,
!   the identifiers for stratiform ice and stratiform water
!   cloud will not be relevant, so there is no ambiguity.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_cloud_type_homogen = 1
!   Cloud composed of mixed water and ice
  INTEGER, Parameter :: IP_cloud_type_water   = 1
!   Cloud composed only of water
  INTEGER, Parameter :: IP_cloud_type_ice     = 2
!   Cloud composed only of ice
  INTEGER, Parameter :: IP_cloud_type_strat   = 1
!   Mixed-phase stratiform cloud
  INTEGER, Parameter :: IP_cloud_type_conv    = 2
!   Mixed-phase convective cloud
  INTEGER, Parameter :: IP_cloud_type_sw      = 1
!   Stratiform water cloud
  INTEGER, Parameter :: IP_cloud_type_si      = 2
!   Stratiform ice cloud
  INTEGER, Parameter :: IP_cloud_type_cw      = 3
!   Convective water cloud
  INTEGER, Parameter :: IP_cloud_type_ci      = 4
!   Convective ice cloud
!
!
!
END MODULE cloud_type_pcf
!+ Module defining continua
!
MODULE continuum_pcf
!
! Description:
!
! This module defines the identifiers defining the physical types
! continua allowed in the radiation code.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  INTEGER, Parameter :: IP_self_continuum = 1
!   Self-broadened continuum
  INTEGER, Parameter :: IP_frn_continuum = 2
!   Foreign-broadened continuum
  INTEGER, Parameter :: IP_n2_continuum = 3
!   Nitrogen continuum
!
END MODULE continuum_pcf
!+ Module to declare a structure of spectral data.
!
MODULE def_spectrum
!
! Description:
!
! This module contains the heirarchical declaration of structures
! of spectral data.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
! Modules used:
  USE realtype_rd
  USE dimensions_spec_ucf
!
!
!
  TYPE StrSpecDim
!
    INTEGER :: nd_type
!     Size allocated for spectral bands (this is always set to the
!     corresponding parameter, but is included here to avoid
!     excessive use of the module of parameters).
    INTEGER :: nd_band
!     Size allocated for spectral bands
    INTEGER :: nd_exclude
!     Size allocated for excluded bands
    INTEGER :: nd_k_term
!     Size allocated for k-terms
    INTEGER :: nd_species
!     Size allocated for gaseous species
    INTEGER :: nd_scale_variable
!     Size allocated for scaling variables
    INTEGER :: nd_brdf_basis_fnc
!     Size allocated for BRDF basis functions
    INTEGER :: nd_brdf_trunc
!     Size allocated for BRDF truncation
    INTEGER :: nd_continuum
!     Size allocated for continua
    INTEGER :: nd_drop_type
!     Size allocated for drop types
    INTEGER :: nd_ice_type
!     Size allocated for ice crystal types
    INTEGER :: nd_aerosol_species
!     Size allocated for aerosol species
    INTEGER :: nd_thermal_coeff
!     Size allocated for thermal coefficients
    INTEGER :: nd_cloud_parameter
!     Size allocated for cloud parameters
    INTEGER :: nd_humidity
!     Size allocated for humidities
    INTEGER :: nd_phase_term
!     Size allocated for terms in the phase function
    INTEGER :: nd_channel
!     Size allocated for spectral channels permitted for output
!
  END TYPE StrSPecDim
!
!
!
  TYPE StrSpecBasic
!
    LOGICAL, Dimension(0: npd_type)       :: l_present
!     Blocks of spectral data in the file
    INTEGER                               :: n_band
!     Number of Spectral Band used
    REAL (RealK), Pointer, Dimension(:)   :: wavelength_long
!     Lower wavelength limits for the band
    REAL (RealK), Pointer, Dimension(:)   :: wavelength_short
!     Higher wavelengths limits for the band
    INTEGER, Pointer, Dimension(:)        :: n_band_exclude
!     Number of exclusions from each band
    INTEGER, Pointer, Dimension(:, :)     :: index_exclude
!     List of excluded bands within each region
!
  END TYPE StrSpecBasic
!
!
!
  TYPE StrSpecSolar
!
    REAL (RealK), Pointer, Dimension(:)      :: solar_flux_band
!     Fraction of the solar spectrum in each band
!
  END TYPE StrSpecSolar
!
!
!
  TYPE StrSpecRayleigh
!
    REAL (RealK), Pointer, Dimension(:)      :: rayleigh_coeff
!     Rayleigh scattering coefficients in each band
!
  END TYPE StrSpecRayleigh
!
!
!
  TYPE StrSpecGas
!
    INTEGER  :: n_absorb
!     Total number of gaseous absorbers
    INTEGER, Pointer, Dimension(:)  :: n_band_absorb
!     Number of gaseous absorbers in each band
    INTEGER, Pointer, Dimension(:, :)  :: index_absorb
!     Number of gaseous absorbers
    INTEGER, Pointer, Dimension(:)  :: type_absorb
!     Actual types of each gas in the spectral file
    INTEGER, Pointer, Dimension(:, :)  :: i_band_k
!     Number of k-terms in each band for each gas
    INTEGER, Pointer, Dimension(:, :)  :: i_scale_k
!     Type of scaling applied to each k-term
    INTEGER, Pointer, Dimension(:, :)  :: i_scale_fnc
!     Type of scaling function
!
    REAL (RealK), Pointer, Dimension(:, :, :)      :: k
!     Absorption coefficients of k-terms
    REAL (RealK), Pointer, Dimension(:, :, :)      :: w
!     Weights for k-terms
    REAL (RealK), Pointer, Dimension(:, :, :, :)      :: scale
!     Scaling parameters for each absorber and term
    REAL (RealK), Pointer, Dimension(:, :)      :: p_ref
!     Reference pressures for scaling functions
    REAL (RealK), Pointer, Dimension(:, :)      :: t_ref
!     Reference temperatures for scaling functions
!
  END TYPE StrSpecGas
!
!
!
  TYPE StrSpecPlanck
!
    INTEGER :: n_deg_fit
!     Degree of the fit to the Planckian function
!
    REAL (RealK), Pointer, Dimension(:, :) :: thermal_coeff
!     Coefficients in polynomial fit to source function
    REAL (RealK)                           :: t_ref_planck
!     Reference temperature for the Plackian function
!
  END TYPE StrSpecPlanck
!
!
!
  TYPE StrSpecCont
!
    INTEGER, Pointer, Dimension(:) :: n_band_continuum
!     Number of continua in each band
    INTEGER, Pointer, Dimension(:, :) :: index_continuum
!     List of continua in each band
    INTEGER :: index_water
!     Index of water vapour of continua in each band
    INTEGER, Pointer, Dimension(:, :) :: i_scale_fnc_cont
!     Types of scaling functions for continua
!
    REAL (RealK), Pointer, Dimension(:, :)         :: k_cont
!     ABsorption coefficients for continuum absorption
    REAL (RealK), Pointer, Dimension(:, :, :)      :: scale_cont
!     Reference temperature for the Plackian function
    REAL (RealK), Pointer, Dimension(:, :)         :: p_ref_cont
!     Reference pressures for continuum scaling functions
    REAL (RealK), Pointer, Dimension(:, :)         :: t_ref_cont
!     Reference temperatures for continuum scaling functions
!
  END TYPE StrSpecCont
!
!
!
  TYPE StrSpecDrop
!
    LOGICAL, Pointer, Dimension(:) :: l_drop_type
!     Flags for types of droplets present
!
    INTEGER, Pointer, Dimension(:) :: i_drop_parm
!     Form of parametrization for each type of droplet 
!
    INTEGER, Pointer, Dimension(:) :: n_phf
!     Number of moments of the phase fuction fitted (N. B. This
!     array is not set for parametrizations which are implicitly
!     restricted to the asymmetry.)
!
    REAL (RealK), Pointer, Dimension(:, :, :)      :: parm_list
!     Parameters used to fit the optical properties of droplets
    REAL (RealK), Pointer, Dimension(:)            :: parm_min_dim
!     Minimum dimension permissible in the parametrization
    REAL (RealK), Pointer, Dimension(:)            :: parm_max_dim
!     Maximum dimension permissible in the parametrization
!
  END TYPE StrSpecDrop
!
!
!
  TYPE StrSpecAerosol
!
    LOGICAL, Pointer, Dimension(:) :: l_aero_spec
!     Flags for species of aerosol present
!
    INTEGER :: n_aerosol
!     Number of aerosol species present
    INTEGER, Pointer, Dimension(:) :: type_aerosol
!     Actual types of aerosols in the spectral file
    INTEGER, Pointer, Dimension(:) :: i_aerosol_parm
!     Parametrization scheme used for each aerosol
    INTEGER, Pointer, Dimension(:) :: n_aerosol_phf_term
!     Number of terms in the phase function
    INTEGER, Pointer, Dimension(:) :: nhumidity
!     Number of values of humidity
!
    REAL (RealK), Pointer, Dimension(:, :, :)      :: abs
!     Absortption by aerosols
    REAL (RealK), Pointer, Dimension(:, :, :)      :: scat
!     Scattering by aerosols
    REAL (RealK), Pointer, Dimension(:, :, :, :)   :: phf_fnc
!     Phase functions of aerosols
    REAL (RealK), Pointer, Dimension(:, :)      :: humidities
!     Humdities of each component
!
  END TYPE StrSpecAerosol
!
!
!
  TYPE StrSpecIce
!
    LOGICAL, Pointer, Dimension(:) :: l_ice_type
!     Flags for types of ice crystals present
!
    INTEGER, Pointer, Dimension(:) :: i_ice_parm
!     Form of parametrization for each type of droplet 
!
    INTEGER, Pointer, Dimension(:) :: n_phf
!     Number of moments of the phase fuction fitted
!
    REAL (RealK), Pointer, Dimension(:, :, :)      :: parm_list
!     Parameters used to fit the optical properties of ice crystals
    REAL (RealK), Pointer, Dimension(:)            :: parm_min_dim
!     Minimum dimension permissible in the parametrization
    REAL (RealK), Pointer, Dimension(:)            :: parm_max_dim
!     Maximum dimension permissible in the parametrization
!
  END TYPE StrSpecIce
!
!
!
  TYPE StrSpecData
    TYPE (StrSpecDim)               :: Dim
    TYPE (StrSpecBasic)             :: Basic
    TYPE (StrSpecSolar)             :: Solar
    TYPE (StrSpecRayleigh)          :: Rayleigh
    TYPE (StrSpecGas)               :: Gas
    TYPE (StrSpecPlanck)            :: Planck
    TYPE (StrSpecCont)              :: Cont
    TYPE (StrSpecAerosol)           :: Aerosol
    TYPE (StrSpecDrop)              :: Drop
    TYPE (StrSpecIce)               :: Ice
  END TYPE StrSpecData

END MODULE def_spectrum
!+ Module to define the elements of single scattering properties
!
MODULE def_ss_prop
!
! Description:
!   This module defines the components of the structure of single
!   scattering propeties,as used throughout the radiation code: 
!   forward scattering properties and raw extinctions are 
!   included for convenience. 
!
!   The model for storage involves a split between the clear-sky
!   properties, dimensioned over (profiles, cloud-free layers)
!   and those in potentially cloudy regions, dimensioned over
!   (profiles, top-most cloudy layer: bottom layer, 0: cloud types)
!   A zero in the third entry refers to clear-sky properties.
!
!   A reordering of this structure to store the clear-sky properties
!   over (profiles, layers) and the cloudy properties over
!   (profiles, top-most cloudy layer: bottom layer, 1:cloud types)
!   would be possible. Which is more convenient depends on the
!   algorithms for cloud overlap.
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
! Modules used:
  USE realtype_rd
!
!
!
  IMPLICIT NONE
!
!
!
  TYPE STR_ss_prop
!
    REAL (RealK), Pointer, Dimension(:, :) :: k_grey_tot_clr
!     Grey extinction in clear-sky region above clouds
    REAL (RealK), Pointer, Dimension(:, :) :: k_ext_scat_clr
!     Scattering in clear-sky region above clouds
    REAL (RealK), Pointer, Dimension(:, :) :: tau_clr
!     Optical depth in clear-sky region above clouds
    REAL (RealK), Pointer, Dimension(:, :) :: omega_clr
!     Albedo of single scattering in clear-sky region above clouds
    REAL (RealK), Pointer, Dimension(:, :, :) :: phase_fnc_clr
!     Phase function in clear-sky region above clouds
!     (Held as moments)
    REAL (RealK), Pointer, Dimension(:, :) :: forward_scatter_clr
!     Forward scattering in clear-sky region above clouds
    REAL (RealK), Pointer, Dimension(:, :) :: forward_solar_clr
!     Solar forward scattering in clear-sky region above clouds
    REAL (RealK), Pointer, Dimension(:, :, :) :: phase_fnc_solar_clr
!     Solar phase function in clear-sky region above clouds
!     (Held as the actual phase function in the viewing direction)
!
    REAL (RealK), Pointer, Dimension(:, :, :) :: k_grey_tot
!     Grey extinction in potentially cloudy regions
    REAL (RealK), Pointer, Dimension(:, :, :) :: k_ext_scat
!     Scattering in potentially cloudy regions
    REAL (RealK), Pointer, Dimension(:, :, :) :: tau
!     Optical depth in potentially cloudy regions
    REAL (RealK), Pointer, Dimension(:, :, :) :: omega
!     Albedo of single scattering in potentially cloudy regions
    REAL (RealK), Pointer, Dimension(:, :, :, :) :: phase_fnc
!     Phase function in potentially cloudy regions
!     (Held as moments)
    REAL (RealK), Pointer, Dimension(:, :, :) :: forward_scatter
!     Forward scattering in potentially cloudy regions
    REAL (RealK), Pointer, Dimension(:, :, :) :: forward_solar
!     Solar forward scattering in potentially cloudy regions
    REAL (RealK), Pointer, Dimension(:, :, :, :) :: phase_fnc_solar
!     Solar phase function in potentially cloudy regions
!     (Held as the actual phase function in the viewing direction)
!
!
  END TYPE STR_ss_prop
!
!
!
END MODULE def_ss_prop
!+    Module to set unit numbers for standard I/O.
!
MODULE def_std_io_icf
!
! Description:
!
! This module defines unit numbers for I/O of standard streams.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  IMPLICIT NONE
!
!
!
  INTEGER, PARAMETER  ::  iu_stdin = 5
!                           Unit number for standard input
  INTEGER, PARAMETER  ::  iu_stdout = 6
!                           Unit number for standard output
  INTEGER, PARAMETER  ::  iu_err = 6
!                           Unit number for error messages
!
END MODULE def_std_io_icf
!+ Module to declare the elements of a spectral file as a namelist.
!
MODULE def_um_nml
!
! Description:
!
! This module defines elements of a spectral as arrays of fixed
! sizes for use as elements of a namelist in the UM. The type of
! variable which can appear in a namelist is quite restricted and
! allocatable and pointer arrays appear not to work.
!
! NOTES:
!    1.) The term "ESFT" is retained in namelists for backward
!        compatibility.
!    2.) AEROSOL_ASYMMETRY and AEROSOL_PHASE_FNC are alternatives,
!        the former being retained for backward compatibility.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
! Modules used:
  USE realtype_rd
  USE dimensions_spec_ucf
!
!
  IMPLICIT NONE
!
!
!- End of header
!
!
!
! General Fields:
!
  LOGICAL :: l_present(0: npd_type)
!   Flag for types of data present
!
!
!
! Properties of the spectral bands:
!
  INTEGER :: n_band
!   Number of spectral bands
!
  REAL  (RealK) :: wave_length_short(npd_band)
!   Shorter wavelength limits
  REAL  (RealK) :: wave_length_long(npd_band)
!   Longer wavelength limits
!
!
!
! Exclusion of specific bands from parts of the spectrum:
!
  INTEGER :: n_band_exclude(npd_band)
!   Number of excluded bands within each spectral band
  INTEGER :: index_exclude(npd_exclude, npd_band)
!   Indices of excluded bands
!
!
!
! Fields for the solar flux:
!
  REAL  (RealK) :: solar_flux_band(npd_band)
!   Fraction of the incident solar flux in each band
!
!
!
! Fields for rayleigh scattering:
!
  REAL  (RealK) :: rayleigh_coefficient(npd_band)
!   Rayleigh coefficients
!
!
!
! Fields for gaseous absorption:
!
  INTEGER :: n_absorb
!   Number of absorbers
  INTEGER :: n_band_absorb(npd_band)
!   Number of absorbers in each band
  INTEGER :: index_absorb(npd_species, npd_band)
!   List of absorbers in each band
  INTEGER :: type_absorb(npd_species)
!   Types of each gas in the spectral file
  INTEGER :: i_band_esft(npd_band, npd_species)
!   Number of esft terms in band for each gas
  INTEGER :: i_scale_esft(npd_band, npd_species)
!   Type of esft scaling
  INTEGER :: i_scale_fnc(npd_band, npd_species)
!   Type of scaling function
!
  REAL  (RealK) :: k_esft(npd_k_term, npd_band, npd_species)
!   ESFT exponents
  REAL  (RealK) :: w_esft(npd_k_term, npd_band, npd_species)
!   ESFT weights
  REAL  (RealK) :: scale_vector(npd_scale_variable, &
    npd_k_term, npd_band, npd_species)
!   Scaling parameters for each absorber and term
  REAL  (RealK) :: p_reference(npd_species, npd_band)
!   Reference pressure for scaling function
  REAL  (RealK) :: t_reference(npd_species, npd_band)
!   Reference temperature for scaling function
!
!
!
! Representation of the Planckian:
!
  INTEGER :: n_deg_fit
!   Degree of thermal polynomial
!
  REAL  (RealK) :: thermal_coefficient(0: npd_thermal_coeff-1, npd_band)
!   Coefficients in polynomial fit to source function
  REAL  (RealK) :: t_ref_planck
!   Planckian reference temperature
!
!
!
! Fields for continua:
!
  INTEGER :: n_band_continuum(npd_band)
!   Number of continua in each band
  INTEGER :: index_continuum(npd_band, npd_continuum)
!   list of continua continuua in each band
  INTEGER :: index_water
!   Index of water vapour
  INTEGER :: i_scale_fnc_cont(npd_band, npd_continuum)
!   Type of scaling function for continuum
!
  REAL  (RealK) :: k_continuum(npd_band, npd_continuum)
!   Grey extinction coefficients for continuum
  REAL  (RealK) :: scale_continuum(npd_scale_variable, &
    npd_band, npd_continuum)
!   Scaling parameters for continuum
  REAL  (RealK) :: p_ref_continuum(npd_continuum, npd_band)
!   Reference pressure for scaling of continuum
  REAL  (RealK) :: t_ref_continuum(npd_continuum, npd_band)
!   Reference temperature for scaling of continuum
!
!
!
! Fields for water droplets:
!
  INTEGER :: i_drop_parametrization(npd_drop_type)
!   Parametrization type of droplets
  INTEGER :: n_drop_phf_term(npd_drop_type)
!   Number of terms in the phase function
!
  LOGICAL :: l_drop_type(npd_drop_type)
!   Types of droplet present
!
  REAL  (RealK) :: drop_parameter_list(npd_cloud_parameter, &
    npd_band, npd_drop_type)
!   Parameters used to fit optical properties of clouds
  REAL  (RealK) :: drop_parm_min_dim(npd_drop_type)
!   Minimum dimension permissible in the parametrization
  REAL  (RealK) :: drop_parm_max_dim(npd_drop_type)
!   Maximum dimension permissible in the parametrization
!
!
!
! Fields for aerosols:
!
  INTEGER :: n_aerosol
!   Number of species of aerosol
  INTEGER :: type_aerosol(npd_aerosol_species)
!   Types of aerosols
  INTEGER :: i_aerosol_parametrization(npd_aerosol_species)
!   Parametrization of aerosols
  INTEGER :: n_aerosol_phf_term(npd_aerosol_species)
!   Number of terms in the phase function
  INTEGER :: nhumidity(npd_aerosol_species)
!   Numbers of humidities
!
  LOGICAL :: L_aerosol_species(npd_aerosol_species)
!   Aerosol species included
!
  REAL  (RealK) :: aerosol_absorption(npd_humidities, &
    npd_aerosol_species, npd_band)
!   Absorption by aerosols
  REAL  (RealK) :: aerosol_scattering(npd_humidities, &
    npd_aerosol_species, npd_band)
!   Scattering by aerosols
  REAL  (RealK) :: aerosol_asymmetry(npd_humidities, &
    npd_aerosol_species, npd_band)
!   Asymmetries of aerosols
  REAL  (RealK) :: aerosol_phase_fnc(npd_humidities, &
    npd_phase_term, npd_aerosol_species, npd_band)
!   Phase function of aerosols
  REAL  (RealK) :: humidities(npd_humidities, npd_aerosol_species)
!   Humidities for components
!
!
!
! Fields for ice crystals:
!
  INTEGER :: i_ice_parametrization(npd_ice_type)
!   Types of parametrization of ice crystals
  INTEGER :: n_ice_phf_term(npd_ice_type)
!   Number of terms in the phase function
!
  LOGICAL :: l_ice_type(npd_ice_type)
!   Types of ice crystal present
!
  REAL  (RealK) :: ice_parameter_list(npd_cloud_parameter, &
    npd_band, npd_ice_type)
!   Parameters used to fit single scattering of ice crystals
  REAL  (RealK) :: ice_parm_min_dim(npd_ice_type)
!   Minimum dimension permissible in the parametrization
  REAL  (RealK) :: ice_parm_max_dim(npd_ice_type)
!   Maximum dimension permissible in the parametrization
!
!
!
! Fields for doppler broadening:
!
  LOGICAL :: l_doppler_present(npd_species)
!   Flag for Doppler broadening for each species
!
  REAL  (RealK) :: doppler_correction(npd_species)
!   Doppler correction terms
!
!
!
END MODULE def_um_nml
!+ Module to set Elsasser''s diffusivity factor.
!
MODULE diff_elsasser_ccf
!
! Description:
!
!   This module defines the diffusivity factor defined by Elsasser.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
! Modules used
  USE realtype_rd
!
!
!
  IMPLICIT NONE
!
!
!
  REAL  (RealK), Parameter :: elsasser_factor = 1.66_RealK
!   Diffusivity factor given by Elsasser
!
!
!
END MODULE diff_elsasser_ccf
!+ Module to set the diffusivity factor for equivalent extinction
!
MODULE diff_keqv_ucf
!
! Description:
!
!   This module defines the diffusivity factor used for IR flux
!   calculations with equivalent extinction.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
! Modules used
  USE realtype_rd
!
!
!
  IMPLICIT NONE
!
!
!
  REAL  (RealK), Parameter :: diffusivity_factor_minor = 1.66_RealK
!   Diffusivity factor applied to flux calculations for minor gases
!   in preliminary calculations.
!
!
!
END MODULE diff_keqv_ucf
!+ Module setting the dimensions of physical fields
!
MODULE dimensions_field_ucf
!
! Description:
!
! This module contains the default sizes for physical arrays. In the
! course of time it should become redundant.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  INTEGER, Parameter :: npd_latitude = 3
!       Number of latitudes
  INTEGER, Parameter :: npd_longitude = 1
!       Number of longitudes
  INTEGER, Parameter :: npd_profile = 3
!       Number of atmospheric profiles
  INTEGER, Parameter :: npd_layer = 101
!       Number of atmospheric layers
  INTEGER, Parameter :: npd_column = 6
!       Maximum number of cloudy subcolumns
  INTEGER, Parameter :: npd_direction = 63
!       Maximum number of directions for radiances
  INTEGER, Parameter :: npd_max_order = 101
!       Maximum order of spherical harmonics used
  INTEGER, Parameter :: npd_profile_aerosol_prsc = 1
!       Size allocated for profiles of prescribed
!       cloudy optical properties
  INTEGER, Parameter :: npd_profile_cloud_prsc = 1
!       Size allocated for profiles of prescribed
!       aerosol optical properties
  INTEGER, Parameter :: npd_opt_level_aerosol_prsc = 10
!       Size allocated for levels of prescribed
!       cloudy optical properties
  INTEGER, Parameter :: npd_opt_level_cloud_prsc = 2
!       Size allocated for levels of prescribed
!       aerosol optical properties
!
!
!
END MODULE dimensions_field_ucf
!+ Module to set internal dimensions tied to algorithms,
!  mostly for clouds.
!
MODULE dimensions_fixed_pcf
!
! Description:
!
! Current Owner of the Code: J.-C. Thelen
!
! History
!
! Version        Date          Comment
! -------        ----          -------
! 2.0            17/10/03      Original Code. (J.-C. Thelen)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of Header

  INTEGER, Parameter :: npd_cloud_component        =  4
!   Number of components of clouds.
  INTEGER, Parameter :: npd_cloud_type             =  4
!   Number of permitted types of clouds.
  INTEGER, Parameter :: npd_cloud_representation   =  4
!   Number of permitted representations of clouds.
  INTEGER, Parameter :: npd_overlap_coeff          = 18
!   Number of overlap coefficients for cloud
  INTEGER, Parameter :: npd_source_coeff           =  2
!   Number of coefficients for two-stream sources
  INTEGER, Parameter :: npd_region                 =  3
!   Number of regions in a layer
!
END MODULE dimensions_fixed_pcf
!+    Module to set error flags in the radiation code.
!
MODULE error_pcf
!
!
! Description:
!
! This module defines the error codes used in the radiation scheme.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  INTEGER, PARAMETER  ::  i_normal = 0
!                           Error free condition
  INTEGER, PARAMETER  ::  i_err_fatal = 1
!                           Fatal error: immediate return
  INTEGER, PARAMETER  ::  i_abort_calculation = 2
!                           Calculation aborted
  INTEGER, PARAMETER  ::  i_missing_data = 3
!                           Missing data error: conditional
  INTEGER, PARAMETER  ::  i_err_io = 4
!                           I/O error
  INTEGER, PARAMETER  ::  i_err_range = 5
!                           Interpolation range error
  INTEGER, PARAMETER  ::  i_err_exist = 6
!                           Existence error
!
END MODULE error_pcf
!+ Module to set indexing numbers of gaseous absorbing species.
!
MODULE gas_list_pcf
!
! Description:
!
!   This module defines the identifiers defining the physical types
!   of each molecular absorbing species.
!   The numbering 1-12 agrees with LOWTRAN 7.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  INTEGER, Parameter :: npd_gases = 19
!   Number of indexed gases
!
  INTEGER, Parameter :: IP_h2o = 1
!   Identifier for water vapour
  INTEGER, Parameter :: IP_co2 = 2
!   Identifier for carbon dioxide
  INTEGER, Parameter :: IP_o3 = 3
!   Identifier for ozone
  INTEGER, Parameter :: IP_n2o = 4
!   Identifier for dinitrogen oxide
  INTEGER, Parameter :: IP_co = 5
!   Identifier for carbon monoxide
  INTEGER, Parameter :: IP_ch4 = 6
!   Identifier for methane
  INTEGER, Parameter :: IP_o2 = 7
!   Identifier for oxygen
  INTEGER, Parameter :: IP_no = 8
!   Identifier for nitrogen monoxide
  INTEGER, Parameter :: IP_so2 = 9
!   Identifier for sulphur dioxide
  INTEGER, Parameter :: IP_no2 = 10
!   Identifier for nitrogen dioxide
  INTEGER, Parameter :: IP_nh3 = 11
!   Identifier for ammonia
  INTEGER, Parameter :: IP_hno3 = 12
!   Identifier for nitric acid
  INTEGER, Parameter :: IP_n2 = 13
!   Identifier for nitrogen
  INTEGER, Parameter :: IP_cfc11 = 14
!   Identifier for CFC11 (CFCl3)
  INTEGER, Parameter :: IP_cfc12 = 15
!   Identifier for CFC12 (CF2Cl2)
  INTEGER, Parameter :: IP_cfc113 = 16
!   Identifier for CFC113 (CF2ClCFCl2)
  INTEGER, Parameter :: IP_hcfc22 = 17
!   Identifier for HCFC22 (CHF2Cl)
  INTEGER, Parameter :: IP_hfc125 = 18
!   Identifier for HFC125 (C2HF5)
  INTEGER, Parameter :: IP_hfc134a = 19
!   Identifier for HFC134A (CF3CFH2)
!
  CHARACTER (LEN=20), Parameter :: name_absorb(npd_gases) = (/ &
                                     "Water Vapour        ", &
                                     "Carbon Dioxide      ", &
                                     "Ozone               ", &
                                     "Dinitrogen Oxide    ", &
                                     "Carbon monoxide     ", &
                                     "Methane             ", &
                                     "Oxygen              ", &
                                     "Nitrogen monoxide   ", &
                                     "Sulphur dioxide     ", &
                                     "Nitrogen dioxide    ", &
                                     "Ammonia             ", &
                                     "Nitric acid         ", &
                                     "Nitrogen            ", &
                                     "CFC11               ", &
                                     "CFC12               ", &
                                     "CFC113              ", &
                                     "HCFC22              ", &
                                     "HFC125              ", &
                                     "HFC134A             "  &
                                    /)
!
END MODULE gas_list_pcf
!+ Module to set methods of overlapping gaseous absorption.
!
MODULE gas_overlap_pcf
!
! Description:
!
!   This module defines the methods of overlapping gaseous
!   absorption within a single spectral band.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_overlap_single        = 1
!   One species only
  INTEGER, Parameter :: IP_overlap_random        = 2
!   Random overlap
  INTEGER, Parameter :: IP_overlap_k_eqv         = 5
!   Equivalent extinction
  INTEGER, Parameter :: IP_overlap_single_int    = 6
!   Interpolated treatment for principal species (provisional
!   code for this was once developed, but was removed: it may
!   be better to proceed with this using adjoint perturbation
!   methods)
!
!
!
END MODULE gas_overlap_pcf
!+ Module to arrays for Gaussian integration.
!
MODULE gaussian_weight_pcf
!
! Description:
!
!   This module defines arrays for Gaussian integration at low
!   orders (for non-scattering IR flux calculations). For
!   higher orders (used in preprocessing) the weights and points 
!   are calculated directly and iteratively.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
! Modules used.
  USE realtype_rd
!
!
!
  IMPLICIT NONE
!
!
!
  INTEGER, Parameter :: NPD_gauss_ord  = 10
!   Maximum order of Gaussian quadrature
!
  INTEGER :: i

  REAL  (RealK), Parameter, &
                 Dimension(NPD_gauss_ord, NPD_gauss_ord) :: &
    gauss_point = RESHAPE( (/ &
      0.0_RealK, (0.0_RealK, i=1, NPD_gauss_ord-1) , &
      -5.77350269189626E-01_RealK, 5.77350269189626E-01_RealK, &
        (0.0_RealK, i=1, NPD_gauss_ord-2), &
      -7.74596669241484E-01_RealK, 0.0_RealK, 7.74596669241484E-01_RealK, &
        (0.0_RealK, i=1, NPD_gauss_ord-3), &
      -8.61136311594053E-01_RealK, -3.39981043584856E-01_RealK, &
        3.39981043584856E-01_RealK, 8.61136311594053E-01_RealK, &
        (0.0_RealK, i=1, NPD_gauss_ord-4), &
      -9.06179845938664E-01_RealK, -5.38469310105683E-01_RealK, &
        0.0_RealK, 5.38469310105683E-01_RealK, 9.06179845938664E-01_RealK, &
        (0.0_RealK, i=1, NPD_gauss_ord-5), &
      -9.32469514203152E-01_RealK, -6.61209386466265E-01_RealK, &
        -2.38619186083197E-01_RealK, 2.38619186083197E-01_RealK, &
        6.61209386466265E-01_RealK, 9.32469514203152E-01_RealK, &
        (0.0_RealK, i=1, NPD_gauss_ord-6), &
      -9.49107912342759E-01_RealK, -7.41531185599394E-01_RealK, &
        -4.05845151377397E-01_RealK, 0.0_RealK, 4.05845151377397E-01_RealK, &
        7.41531185599394E-01_RealK, 9.49107912342759E-01_RealK, &
        (0.0_RealK, i=1, NPD_gauss_ord-7), &
      -9.60289856497536E-01_RealK, -7.96666477413627E-01_RealK, &
        -5.25532409916329E-01_RealK, -1.83434642495650E-01_RealK, &
        1.83434642495650E-01_RealK, 5.25532409916329E-01_RealK, &
        7.96666477413627E-01_RealK, 9.60289856497536E-01_RealK, &
        (0.0_RealK, i=1, NPD_gauss_ord-8), &
      -9.68160239507626E-01_RealK, -8.36031107326636E-01_RealK, &
        -6.13371432700590E-01_RealK, -3.24253423403809E-01_RealK, 0.0_RealK, &
        3.24253423403809E-01_RealK, 6.13371432700590E-01_RealK, &
        8.36031107326636E-01_RealK, 9.68160239507626E-01_RealK, &
        (0.0_RealK, i=1, NPD_gauss_ord-9), &
      -9.73906528517172E-01_RealK, -8.65063366688985E-01_RealK, &
        -6.79409568299024E-01_RealK, -4.33395394129427E-01_RealK, &
        -1.48874338981631E-01_RealK, 1.48874338981631E-01_RealK, &
        4.33395394129427E-01_RealK, 6.79409568299024E-01_RealK, &
        8.65063366688985E-01_RealK, 9.73906528517172E-01_RealK &
      /), (/ NPD_gauss_ord, NPD_gauss_ord /) )
!   Points of Gaussian integration
!
  REAL  (RealK), Parameter, &
                 Dimension(NPD_gauss_ord, NPD_gauss_ord) :: &
                   gauss_weight = RESHAPE( (/ &
    2.0_RealK, (0.0_RealK, i=1, NPD_gauss_ord-1), &
    1.0_RealK, 1.0_RealK, (0.0_RealK, i=1, NPD_gauss_ord-2), &
    5.55555555555556E-01_RealK, 8.88888888888889E-01_RealK, &
      5.55555555555556E-01_RealK, (0.0_RealK, i=1, NPD_gauss_ord-3), &
    3.47854845137454E-01_RealK, 6.52145154862546E-01_RealK, &
      6.52145154862546E-01_RealK, 3.47854845137454E-01_RealK, &
      (0.0_RealK, i=1, NPD_gauss_ord-4), &
    2.36926885056189E-01_RealK, 4.78628670499366E-01_RealK, &
      4.67913934572691E-01_RealK, 4.78628670499366E-01_RealK, &
      2.36926885056189E-01_RealK, (0.0_RealK, i=1, NPD_gauss_ord-5), &
    1.71324492379170E-01_RealK, 3.60761573048139E-01_RealK, &
      4.67913934572691E-01_RealK, 4.67913934572691E-01_RealK, &
      3.60761573048139E-01_RealK, 1.71324492379170E-01_RealK, &
      (0.0_RealK, i=1, NPD_gauss_ord-6), &
    1.29484966168870E-01_RealK, 2.79705391489277E-01_RealK, &
      3.81830050505119E-01_RealK, 4.17959183673469E-01_RealK, &
      3.81830050505119E-01_RealK, 2.79705391489277E-01_RealK, &
      1.29484966168870E-01_RealK, (0.0_RealK, i=1, NPD_gauss_ord-7), &
    1.01228536290376E-01_RealK, 2.22381034453374E-01_RealK, &
      3.13706645877887E-01_RealK, 3.62683783378362E-01_RealK, &
      3.62683783378362E-01_RealK, 3.13706645877887E-01_RealK, &
      2.22381034453374E-01_RealK, 1.01228536290376E-01_RealK, &
      (0.0_RealK, i=1, NPD_gauss_ord-8), &
    8.1274388361574E-02_RealK, 1.80648160694857E-01_RealK, &
      2.60610696402935E-01_RealK, 3.12347077040003E-01_RealK, &
      3.30239355001260E-01_RealK, 3.12347077040003E-01_RealK, &
      2.60610696402935E-01_RealK, 1.80648160694857E-01_RealK, &
      8.1274388361574E-02_RealK, (0.0_RealK, i=1, NPD_gauss_ord-9), &
    6.6671344308688E-02_RealK, 1.49451349150581E-01_RealK, &
      2.19086362515982E-01_RealK, 2.69266719309996E-01_RealK, &
      2.95524224714753E-01_RealK, 2.95524224714753E-01_RealK, &
      2.69266719309996E-01_RealK, 2.19086362515982E-01_RealK, &
      1.49451349150581E-01_RealK, 6.6671344308688E-02_RealK &
      /), (/ NPD_gauss_ord, NPD_gauss_ord /) )
!   Weights for Gaussian integration
!
!
!
END MODULE gaussian_weight_pcf
!+ Module to set numbers for ice cloud schemes.
!
MODULE ice_cloud_parametrization_pcf
!
! Description:
!
!   This module defines the available parametrization schemes
!   for ice crystals.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
 INTEGER, Parameter ::  npd_ice_cloud_fit = 12
!   Number of cloud fitting schemes
!
 INTEGER, Parameter :: IP_Slingo_Schrecker_ice = 1
!   Parametrization of Slingo and Schrecker.
 INTEGER, Parameter :: IP_ice_unparametrized = 3
!   Unparametrized ice crystal data
 INTEGER, Parameter :: IP_Sun_Shine_Vn2_Vis = 4
!   Sun and Shine''s parametrization in the visible (version 2)
 INTEGER, Parameter :: IP_Sun_Shine_Vn2_IR = 5
!   Sun and Shine''s parametrization in the IR (version 2)
 INTEGER, Parameter :: IP_ice_ADT = 6
!   ADT-based scheme for ice crystals
 INTEGER, Parameter :: IP_ice_ADT_10 = 7
!   ADT-based scheme for ice crystals using 10th order
!   polynomials
 INTEGER, Parameter :: IP_ice_parametrization_test = 8
!   Test parametrization for ice crystals
 INTEGER, Parameter :: IP_ice_Fu_Solar = 9
!   Fu''s parametrization in the solar region of the spectrum
 INTEGER, Parameter :: IP_ice_Fu_IR = 10
!   Fu''s parametrization in the infra-red region of the spectrum
 INTEGER, Parameter :: IP_Slingo_Schr_ice_PHF = 11
!   Parametrization of the same type as Slingo and Schrecker''s, but
!   with each moment of the phase function treated separately
 INTEGER, Parameter :: IP_ice_Fu_PHF = 12
!   Parametrization of the same type as Fu''s IR scheme, but with each
!   moment of the phase function treated individually
!
END MODULE ice_cloud_parametrization_pcf
!+ Module to set types of k-scaling permitted.
!
MODULE k_scale_pcf
!
! Description:
!   This module defines the available treatments of the scaling
! function for each term.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  IMPLICIT NONE
!
!
!
  INTEGER, Parameter :: IP_scale_null = 0
!   No scaling at all
  INTEGER, Parameter :: IP_scale_band = 1
!   Same scaling for all terms in the band 
  INTEGER, Parameter :: IP_scale_term = 2
!   Different scaling for each k-term
!
!
END MODULE k_scale_pcf
!+ Module to define mathematical constants.
!
MODULE math_cnst_ccf
!
! Description:
!
! This module defines mathematical constants used in the code.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
! Modules used:
  USE realtype_rd
!
  REAL  (RealK), PARAMETER :: PI = 3.14159265358979323846E+00_RealK
!                               Value of pi
!
END MODULE math_cnst_ccf
!+ Module to set identifiers for phases of water.
!
MODULE phase_pcf
!
! Description:
!
!   This module defines the phases of cpondensed water.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_phase_water  = 1
!   Liquid phase
  INTEGER, Parameter :: IP_phase_ice    = 2
!   Ice phase
!
!
!
END MODULE phase_pcf
!+ Module to set physical constants.
!
MODULE physical_constants_0_ccf
!
! Description:
!
!   This module defines physical constants used in the model.
!   The splitting of physical constants between different modules
!   is purely for convenience.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
! Modules used
  USE realtype_rd
!
!
!
  IMPLICIT NONE
!
!
!
  REAL  (RealK), Parameter :: mol_weight_air   = 28.966E-03_RealK
!   Molar weight of dry air

  REAL  (RealK), Parameter :: seconds_per_day  = 8.6400E+04_RealK
!   Number of seconds in a day

  REAL  (RealK), Parameter :: n2_mass_frac     = 0.781E+00_RealK
!   Mass fraction of nitrogen
!
!
!
END MODULE physical_constants_0_ccf
!+ Module to set physical constants.
!
MODULE physical_constants_1_ccf
!
! Description:
!
!   This module defines physical constants used in the model.
!   The splitting of physical constants between different modules
!   is purely for convenience.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
! Modules used
  USE realtype_rd
!
!
!
  IMPLICIT NONE
!
!
!
  REAL  (RealK), Parameter :: grav_acc           = 9.80866_RealK
!   Acceleration due to gravity
  REAL  (RealK), Parameter :: r_gas              = 8.3143_RealK
!   Universal gas constant
  REAL  (RealK), Parameter :: r_gas_dry          = 287.026_RealK
!   Universal gas constant
  REAL  (RealK), Parameter :: cp_air_dry         = 1.005E+03_RealK
!   Specific heat of dry air
  REAL  (RealK), Parameter :: ratio_molar_weight = 28.966_RealK / &
                                                   18.0153_RealK
!   Molecular weight of dry air/ molecular weight of water
!
!
!
END MODULE physical_constants_1_ccf
!+ Module to set types of scaling for absorber amounts.
!
MODULE scale_fnc_pcf
!
! Description:
!   This module defines the available scaling functions.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
  IMPLICIT NONE
!
!
!
  INTEGER, Parameter :: npd_scale_fnc = 3
!   Number of scaling functions allowed
  INTEGER, Parameter, Dimension(0: npd_scale_fnc) :: n_scale_variable = &
    (/ 0, 2, 3, 4 /)
!   Number of parameters in scaling functions
!
  INTEGER, Parameter :: IP_scale_fnc_null = 0
!   Null scaling function
  INTEGER, Parameter :: IP_scale_power_law = 1
!   Power law scaling function
  INTEGER, Parameter :: IP_scale_power_quad = 2
!   Power law for p; quadratic for T
  INTEGER, Parameter :: IP_scale_doppler_quad = 3
!   Power law for p; quadratic for T with implicit 
!   Doppler correction
!
END MODULE scale_fnc_pcf
!+ Module to set usages for treating scattering.
!
MODULE scatter_method_pcf
!
! Description:
!
!   This module defines the modes in which scattering may
!   be treated. These methods refer to the generation of
!   the transmission and reflection coefficients, not to
!   the solvers used. Hence, there is no reference to approximate
!   scattering because that is a choice of solver using 
!   defined transmission and reflection coefficients.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_scatter_full      = 1
!   Full treatment of scattering
  INTEGER, Parameter :: IP_no_scatter_abs    = 2
!   Scattering ignored completely: this is often sufficiently
!   accurate in the IR where scattering is prodominantly in
!   the forward direction
  INTEGER, Parameter :: IP_no_scatter_ext    = 3
!   Scattering treated as absorption: this is a reasonable
!   approximation only very rarely for small particles at
!   long wavelengths.
!
!
!
END MODULE scatter_method_pcf
!+ Module to set solvers for two-stream equations
!
MODULE solver_pcf
!
! Description:
!
!   This module defines the identifiers for solvers used in
!   two-stream methods. The types of solvers may first be
!   classified by the treatment of cloud overlap (single
!   columns as in the IPA or coupled schemes following
!   Geleyn and Hollingsworth (1979)), and secondly by the
!   algorithm selected. For example, in the case of single
!   columns, the equations may be formed as a tridiagonal
!   system with reflection coefficients down the diagonal
!   (this produces ill-conditioning in absorbing conditions)
!   or as a diagonally dominant pentadiagonal system with
!   unit diagonal entries (which is better conditioned but
!   more expensive). These may be solved using standard banded
!   methods. The most effective method of solution, however,
!   is not to use a black-box algorithm, but to devise an
!   explicit implementation of Gaussian elimination, noting
!   the positions of the zeros in the matrix: this can be started
!   from the pentadiagonal matrix. This is as cheap as a
!   tridiagonal solver and amounts to proceeding up the column
!   constructing cumulative albedos for the lower layers and
!   then substituting downwards, which has been described as
!   a separate algorithm. In a sense, then, the debate in 
!   the literature some years ago about two-stream solvers is
!   largely irrelevant and good methods are pretty much equivalent.
!
!   Note, however, that no pivoting is done. It is believed that
!   this will be unnecessary with double precision arithmetic.
!   Single precision arithemtic is not recommended and there is
!   evidence that occasionally rounding error may become important.
!   
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_solver_pentadiagonal      = 1
!   Pentadiagonal solver for homogeneous column
  INTEGER, Parameter :: IP_solver_mix_11             = 6
!   Coupled overlap scheme using full endekadiagonal matrix
  INTEGER, Parameter :: IP_solver_mix_app_scat       = 9
!   Coupled overlap scheme with approximate scattering
  INTEGER, Parameter :: IP_solver_mix_net_app_scat   = 10
!   Coupled overlap for net fluxes with approximate scattering
  INTEGER, Parameter :: IP_solver_mix_direct         = 11
!   Direct solution for full fluxes with coupled overlap
  INTEGER, Parameter :: IP_solver_mix_direct_net     = 12
!   Direct solution for net fluxes with coupled overlap 
  INTEGER, Parameter :: IP_solver_homogen_direct     = 13
!   Direct solution in a homogeneous column
  INTEGER, Parameter :: IP_solver_triple             = 14
!   Direct solution for coupled overlap with separation between
!   convective and stratiform clouds
  INTEGER, Parameter :: IP_solver_triple_app_scat    = 15
!   Direct solution for coupled overlap with separation between
!   convective and stratiform clouds with approximate scattering
  INTEGER, Parameter :: IP_solver_mix_direct_hogan   = 16
!   Direct solution for full fluxes with coupled overlap 
!   (modified for correct treatment of shadowing by Robin Hogan)
  INTEGER, Parameter :: IP_solver_triple_hogan       = 17
!   Direct solution for coupled overlap with separation between
!   convective and stratiform clouds (modified for correct
!   treatment of shadowing by Robin Hogan)
!
!
END MODULE solver_pcf
!+ Module to set pointers to array locations for source functions.
!
MODULE source_coeff_pointer_pcf
!
! Description:
!
!   This module defines pointers to positions in the array
!   of source coefficients where coefficients for individual
!   terms are held. Since the SW and LW calculations are separate
!   numbers can be reused. Pointer arrays in structure might
!   be a clearer way of doing things in full F90.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_scf_solar_up   = 1
!   Pointer to source coeficient for upward solar beam
  INTEGER, Parameter :: IP_scf_solar_down = 2
!   Pointer to source coeficient for downward solar beam
  INTEGER, Parameter :: IP_scf_ir_1d      = 1
!   Pointer to source coeficient for 1st difference of Planckian
  INTEGER, Parameter :: IP_scf_ir_2d      = 2
!   Pointer to source coeficient for 2nd difference of Planckian
!
!
!
END MODULE source_coeff_pointer_pcf
!+ Module to define different regions of the spectrum
!
MODULE spectral_region_pcf
!
! Description:
!
!   This module defines the spectral regions knwon to the radiation
!   code.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!   Language: Fortran 90
!
!- End of header
!
!
!
  INTEGER, Parameter :: IP_solar     = 1
!   Solar region
  INTEGER, Parameter :: IP_infra_red = 2
!   Infra-red region
!
END MODULE spectral_region_pcf
!+ Module to set algorithms for spherical harmonic calculations.
!
MODULE sph_algorithm_pcf
!
! Description:
!
!   This module defines the algorithms available for spherical
!   harmonic calculations. Initially, this refers to the method
!   used to calculate radiances.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_sph_direct  = 1
!   Direct solution using spherical harmonics
  INTEGER, Parameter :: IP_sph_reduced_iter = 2
!   The spherical harmonic solution a reduced order of
!   truncation is used to define a source
!   term for integration along a line: this can be combined
!   with a higher order of truncation for the solar beam
!   to yield a solution almost identical to the TMS method
!   of Nakajima and Tanaka.
!
!
!
END MODULE sph_algorithm_pcf
!+ Module to set usages for spherical harmonic algorithm
!
MODULE sph_mode_pcf
!
! Description:
!
!   This module defines the modes in which the spherical
!   harmonic algorithm may be used, essentially meaning
!   the type of result from the calculation. The entry for
!   actinic fluxes is as yet a place-holder.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_sph_mode_rad  = 1
!   Spherical harmonics are used to calculate radiances
  INTEGER, Parameter :: IP_sph_mode_flux = 2
!   The spherical harmonic solution a reduced order of
!   truncation is used to define a source
!   term for integration along a line: this can be combined
!   with a higher order of truncation for the solar beam
!   to yield a solution almost identical to the TMS method
!   of Nakajima and Tanaka
  INTEGER, Parameter :: IP_sph_mode_j    = 3
!   Spherical harmonics are used to calculate mean
!   radiances (actinic flux/4 pi)
!
!
!
END MODULE sph_mode_pcf
!+ Module to set algorithmic control of the QR algorithm.
!
MODULE sph_qr_iter_acf
!
! Description:
!
!   This module defines the tolerance relative to the machine''s
!   precision for convergence of the QR-algorithm for determining
!   eigenvalues of a matrix.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
! Modules used
  USE realtype_rd
!
!
!
  IMPLICIT NONE
!
!
!
  REAL  (RealK), Parameter :: RP_tol_factor_sph_qr  = 1.0E+02_RealK
!   Tolerance factor to be applied to the precision of the
!   machine to define the tolerance for the algorithm
!
!
!
END MODULE sph_qr_iter_acf
!+ Module to set types of truncation for spherical harmonics.
!
MODULE sph_truncation_pcf
!
! Description:
!
!   This module defines the types of truncation used with
!   spherical harmonics: this refers to the harmonics Y_l^m
!   retained. The defined patterns closely resemble those
!   used in CFD.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_trunc_triangular  = 1
!   Triangular truncation (all modes with m <= l_max)
  INTEGER, Parameter :: IP_trunc_rhombohedral = 2
!   Rhombohedral truncation (all modes with l+m <= l_max)
  INTEGER, Parameter :: IP_trunc_azim_sym    = 3
!   Only modes with m=0 (axial symmetry for the IR and flux
!   calculations).
  INTEGER, Parameter :: IP_trunc_adaptive    = 4
!   Truncation chosen adaptively for each l as l increases.
!
!
!
END MODULE sph_truncation_pcf
!+ Module to set usages for specifying surface characteristics.
!
MODULE surface_spec_pcf
!
! Description:
!
!   This module defines the modes in which the surface
!   Characteristics may be specified. This is an area for
!   development and current capabilities are not complete.
!   Further, some of the older methods are effectively obsolete.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_surface_specified           = 1
!   Properties specified by surface type
  INTEGER, Parameter :: IP_surface_internal            = 2
!   Properties passed into radiation code from the driving
!   routine (typically the case in a GCM).
  INTEGER, Parameter :: IP_surface_polynomial          = 3
!   Direct albedo fitted a polynomial in the cosine
!   of the zenith angle (Lambertian diffuse albedo)
  INTEGER, Parameter :: IP_surface_payne               = 4
!   Direct albedo fitted Using Payne''s functional form,
!   with a Lambertian diffuse albedo
  INTEGER, Parameter :: IP_surface_lambertian          = 5
!   Completely Lambertian surface
  INTEGER, Parameter :: IP_surface_roujean             = 6
!   BRDF represented using Roujean''s basis
  INTEGER, Parameter :: IP_surface_lommel_seeliger_axi = 7
!   BRDF represented using an axisymmetric Lommel-Seeliger
!   function (for flux calculations over the sea)
!
!  Pointers to specific components of arrays
!
  INTEGER, Parameter :: IP_surf_alb_dir =2
!           Pointer to direct surface albedo
  INTEGER, Parameter :: IP_surf_alb_diff =1
!           Pointer to diffuse surface albedo

END MODULE surface_spec_pcf
!+ Module to define identifiers for two-stream approximations.
!
MODULE two_stream_scheme_pcf
!
! Description:
!
!   This module defines identifiers for the two-stream schemes
!   recognized in the code. The two-stream conept refers simply
!   to upward and downward fluxes. How the angular variation of
!   the radiation is approximated differs between indiviual forms
!   of the approximation. Separate identifiers are not provided
!   for delta-rescaled schemes since rescaling is a generic 
!   procedure.
!
! Current Owner of the Code: J. M. Edwards
!
! History:
!
! Version       Date            Comment
! -------       ----            -------
! 2.0           09/01/2002      Original Code. (J. M. Edwards)
!
! Code Description:
!
! Language: Fortran 90
!
!- End of header
!
!
!
  IMPLICIT NONE
!
!
  INTEGER, Parameter :: IP_eddington           = 2
!   Eddington''s approximation
  INTEGER, Parameter :: IP_discrete_ord        = 4
!   Discrete ordinate method
  INTEGER, Parameter :: IP_ifm                 = 5
!   Improved flux method
  INTEGER, Parameter :: IP_pifm85              = 6
!   Practical improved flux method (version of Zdunkowski et al. (1985))
  INTEGER, Parameter :: IP_zdk_flux            = 7
!   Zdunkowski''s flux method
  INTEGER, Parameter :: IP_krschg_flux         = 8
!   Kerschgen''s flux method
  INTEGER, Parameter :: IP_coakley_chylek_1    = 9
!   Coakley & Chylek''s 1st method
  INTEGER, Parameter :: IP_coakley_chylek_2    = 10
!   Coakley & Chylek''s 2nd method
  INTEGER, Parameter :: IP_meador_weaver       = 11
!   Meador & Weaver''s method
  INTEGER, Parameter :: IP_elsasser            = 12
!   Practical improved flux method (1985) with Elsasser''s
!   diffusivity
  INTEGER, Parameter :: IP_2s_test             = 14
!   User''s defined test approximation
  INTEGER, Parameter :: IP_hemi_mean           = 15
!   Hemispheric mean approximation
  INTEGER, Parameter :: IP_pifm80              = 16
!   Practical improved flux method (original form of 1980)
!
!
!
END MODULE two_stream_scheme_pcf
MODULE ESRAD

    PRIVATE
   
    PUBLIC :: radiance_calc
    PUBLIC :: read_spectrum_90

CONTAINS
!+ Subroutine to calculate the radiance field.N
!
! Method:
!        Properties independent of the spectral bands are set.
!        a loop over bands is then entered. Grey optical properties
!        are set and an appropriate subroutine is called to treat
!        the gaseous overlaps. The final radiances are assigned.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   Fortran 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE radiance_calc(ierr &
!                        Logical flags for processes
        , l_rayleigh, l_aerosol, l_gas, l_continuum &
        , l_cloud, l_drop, l_ice &
!                        Angular integration
        , i_angular_integration, l_rescale, n_order_forward &
        , i_2stream &
        , n_order_gauss &
        , i_truncation, ls_global_trunc, ms_min, ms_max &
        , accuracy_adaptive, euler_factor &
        , l_henyey_greenstein_pf, ls_brdf_trunc &
        , i_sph_algorithm, n_order_phase_solar &
        , n_direction, direction &
        , n_viewing_level, viewing_level, i_sph_mode &
!                        Treatment of scattering
        , i_scatter_method &
!                       Options for treating clouds
        , l_global_cloud_top, n_global_cloud_top &
!                        Options for solver
        , i_solver &
!                        Properties of diagnostics
        , map_channel &
!                        General spectral properties
        , n_band, i_first_band, i_last_band, weight_band &
!                        General atmospheric properties
        , n_profile, n_layer &
        , p, t, t_ground, t_level, d_mass &
!                        Spectral region
        , isolir &
!                        Solar fields
        , zen_0, solar_irrad, solar_flux_band &
        , rayleigh_coefficient &
!                        Infra-red fields
        , n_deg_fit, thermal_coefficient, t_ref_planck &
        , l_ir_source_quad &
!                        Gaseous absorption
        , i_gas_overlap, i_gas &
        , gas_mix_ratio, n_band_absorb, index_absorb &
        , i_band_esft, w_esft, k_esft, i_scale_esft &
        , i_scale_fnc, scale_vector &
        , p_reference, t_reference &
!                        Doppler broadening
        , l_doppler, doppler_correction &
!                        Surface fields
        , n_brdf_basis_fnc, rho_alb, f_brdf &
!                        Tiling options for heterogeneous surfaces
        , l_tile, n_point_tile, n_tile, list_tile, rho_alb_tile &
        , frac_tile, t_tile &
!                        Continuum absorption
        , n_band_continuum, index_continuum, index_water &
        , k_continuum, i_scale_fnc_cont, scale_continuum &
        , p_ref_continuum, t_ref_continuum &
!                        Properties of aerosols
        , n_aerosol, aerosol_mix_ratio &
        , aerosol_absorption, aerosol_scattering &
        , n_aerosol_phf_term, aerosol_phase_fnc &
        , i_aerosol_parametrization, nhumidity, humidities &

        , n_opt_level_aerosol_prsc, n_phase_term_aerosol_prsc &
        , aerosol_pressure_prsc, aerosol_absorption_prsc &
        , aerosol_scattering_prsc, aerosol_phase_fnc_prsc &

!                        Properties of clouds
        , n_condensed, type_condensed &
        , i_cloud, i_cloud_representation, w_cloud &
        , n_cloud_type, frac_cloud &
        , condensed_mix_ratio, condensed_dim_char &
        , i_condensed_param, condensed_n_phf, condensed_param_list &
        , dp_corr_strat, dp_corr_conv &

        , n_opt_level_drop_prsc, n_phase_term_drop_prsc &
        , drop_pressure_prsc, drop_absorption_prsc &
        , drop_scattering_prsc, drop_phase_fnc_prsc &
        , n_opt_level_ice_prsc, n_phase_term_ice_prsc &
        , ice_pressure_prsc, ice_absorption_prsc &
        , ice_scattering_prsc, ice_phase_fnc_prsc &

!                        Calculated Fluxes or Radiances
        , flux_direct, flux_down, flux_up, radiance, photolysis &
!                        Options for clear-sky fluxes
        , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
        , flux_direct_clear, flux_down_clear, flux_up_clear &
!                        Special Surface Fluxes
        , l_blue_flux_surf, weight_blue &
        , flux_direct_blue_surf &
        , flux_down_blue_surf, flux_up_blue_surf &
!                        Tiled Surface Fluxes
        , flux_up_tile, flux_up_blue_tile &
!                        Dimensions of arrays
        , nd_profile, nd_layer, nd_column, nd_layer_clr, id_ct &
        , nd_2sg_profile, nd_flux_profile, nd_radiance_profile &
        , nd_j_profile &
        , nd_channel, nd_band &
        , nd_species, nd_esft_term, nd_scale_variable &
        , nd_continuum &
        , nd_aerosol_species, nd_humidities &
        , nd_cloud_parameter &
        , nd_thermal_coeff, nd_source_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc &

        , nd_profile_aerosol_prsc, nd_profile_cloud_prsc &
        , nd_opt_level_aerosol_prsc, nd_opt_level_cloud_prsc &

        , nd_phase_term, nd_max_order, nd_sph_coeff &
        , nd_direction, nd_viewing_level &
        , nd_region, nd_cloud_type, nd_cloud_component &
        , nd_overlap_coeff &
        , nd_point_tile, nd_tile &
        )
!
!
!
!     Modules used.
      USE realtype_rd
      USE def_ss_prop
      USE def_std_io_icf
      USE gas_overlap_pcf
      USE cloud_scheme_pcf
      USE cloud_region_pcf
      USE angular_integration_pcf
      USE sph_algorithm_pcf
      USE spectral_region_pcf
      USE aerosol_parametrization_pcf
      USE k_scale_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_layer_clr &
!           Size allocated for totally clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_2sg_profile &
!           Size allocated for profiles of fluxes
        , nd_flux_profile &
!           Size allocated for profiles of output fluxes
        , nd_radiance_profile &
!           Size allocated for profiles of radiances
        , nd_j_profile &
!           Size allocated for profiles of mean radiances
        , nd_channel &
!           Size allocated for channels of output
        , nd_band &
!           Size allocated for bands in spectral computation
        , nd_species &
!           Size allocated for gaseous species
        , nd_continuum &
!           Size allocated for types of continua
        , nd_aerosol_species &
!           Size allocated for aerosol species
        , nd_humidities &
!           Size allocated for humidities
        , nd_esft_term &
!           Size allocated for ESFT terms
        , nd_scale_variable &
!           Size allocated for variables in scaling functions
        , nd_cloud_parameter &
!           Size allocated for cloud parameters
        , nd_thermal_coeff &
!           Size allocated for thermal coefficients
        , nd_source_coeff &
!           Size allocated for two-stream source coefficients
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for truncation of BRDF basis functions
        , nd_column &
!           Size allocated for columns at each grid-point
        , nd_phase_term &
!           Size allocated for terms in the phase function
!           supplied to the routine
        , nd_max_order &
!           Size allocated for polar orders
        , nd_direction &
!           Size allocated for viewing directions at each point
        , nd_viewing_level &
!           Size allocated for levels where the radiance
!           may be calculated
        , nd_region &
!           Size allocated for cloudy regions
        , nd_cloud_type &
!           Size allocated for types of clouds
        , nd_cloud_component &
!           Size allocated for components in clouds
        , nd_overlap_coeff &
!           Size allocated for overlap coefficients
        , nd_sph_coeff &
!           Size allocated for arrays of spherical coefficients
!           used in determining radiances

        , nd_profile_aerosol_prsc &
!           Size allocated for profiles of prescribed
!           aerosol optical properties
        , nd_profile_cloud_prsc &
!           Size allocated for profiles of prescribed
!           cloudy optical properties
        , nd_opt_level_aerosol_prsc &
!           Size allocated for levels of prescribed
!           aerosol optical properties
        , nd_opt_level_cloud_prsc &
!           Size allocated for levels of prescribed
!           cloudy optical properties

        , nd_point_tile &
!           Size allocated for points with surface tiling
        , nd_tile
!           Size allocated for the number of tiles
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!str  General logical switches:
      LOGICAL, Intent(IN) :: &
          l_clear &
!           Calculate clear-sky fluxes
        , l_ir_source_quad &
!           Use a quadratic source function
        , l_rescale &
!           Flag for delta-rescaling
        , l_henyey_greenstein_pf
!           Use Henyey-Greenstein phase functions
!
!str  Parameters controlling algorithms:
!     Representation of clouds:
      INTEGER, Intent(IN) :: &
          i_cloud
!           Cloud scheme used
!     Numerical algorithms:
      INTEGER, Intent(IN) :: &
          map_channel(nd_band)
!           Mapping of actual bands to the output channels
      INTEGER, Intent(IN) :: &
          isolir &
!           Visible or IR
        , i_solver &
!           Solver used
        , i_solver_clear &
!           Clear solver used
        , i_2stream &
!           Two-stream scheme
        , i_angular_integration &
!           Angular integration scheme
        , n_order_gauss &
!           Order of Gaussian integration
        , i_truncation &
!           Type of spherical truncation
        , ls_global_trunc &
!           Truncating order of spherical harmonics
        , ms_min &
!           Lowest azimuthal order calculated
        , ms_max &
!           Highest azimuthal order calculated
        , n_order_forward &
!           Order of the term used to `define'' the forward scattering
!           fraction.
        , i_sph_mode &
!           Mode in which the spherical harmonic solver is being used
        , i_sph_algorithm
!           Algorithm used for spherical harmonic calculation
      REAL  (RealK), Intent(IN) :: &
          accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last term of an alternating series
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc
!           Order of truncation applied to BRDFs
!           (This will be reset to 0 if a Lambertian surface
!           is assumed)
!
!     Specification of the viewing geometry
      INTEGER, Intent(IN) :: &
          n_direction &
!           Number of directions at which to calculate radiances
        , n_viewing_level
!           Number of levels where the radiance is required
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2) &
!           Directions in which to calculate radiances
        , viewing_level(nd_viewing_level)
!           List of levels where the radiance is required
!
!     Range of spectral bands:
      INTEGER, Intent(IN) :: &
          i_first_band &
!           First band
        , i_last_band
!           Last band
!
!     General properties of spectrum:
      INTEGER, Intent(IN) :: &
          n_band &
!           Number of spectral bands
        , n_aerosol
!           Number of aerosol species
!
!str  Solar fields:
      REAL  (RealK), Intent(IN) :: &
          solar_irrad(nd_profile) &
!           Incident solar radiation
        , solar_flux_band(nd_band) &
!           Normalized flux in each spectral band
        , zen_0(nd_profile)      
!           Secant (two-stream) or cosine (spherical harmonics)
!           of solar zenith angle
!
!str  Atmospheric profiles:
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
      REAL  (RealK), Intent(IN) :: &
          p(nd_profile, nd_layer) &
!           Pressure
        , t(nd_profile, nd_layer) &
!           Temperature
        , t_ground(nd_profile) &
!           Temperature of ground
        , t_level(nd_profile, 0: nd_layer) &
!           Temperature on levels
        , d_mass(nd_profile, nd_layer) &
!           Mass thickness of each layer
        , gas_mix_ratio(nd_profile, nd_layer, nd_species)
!           Gaseous mass mixing ratios
!
!str  Surface properties:
      INTEGER, Intent(IN) :: &
          n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, nd_brdf_basis_fnc, nd_band) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc)
!           Array of BRDF basis terms
!
!str  Arrays related to tiling of the surface
      LOGICAL, Intent(IN) :: &
          l_tile
!           Local to allow tiling options
      INTEGER, Intent(IN) :: &
          n_point_tile &
!           Number of points to tile
        , n_tile &
!           Number of tiles used
        , list_tile(nd_point_tile)
!           List of points with surface tiling
      REAL  (RealK), Intent(INOUT) :: &
          rho_alb_tile(nd_point_tile, nd_brdf_basis_fnc &
            , nd_tile, nd_band) &
!           Weights for the basis functions of the BRDFs
!           at the tiled points
        , frac_tile(nd_point_tile, nd_tile) &
!           Fraction of tiled grid-points occupied by each tile
        , t_tile(nd_point_tile, nd_tile)
!           Local surface temperatures on individual tiles
!
!str  Rayleigh scattering:
      LOGICAL, Intent(IN) :: &
          l_rayleigh
!           Include rayleigh scattering in the calculation.
      REAL  (RealK), Intent(IN) :: &
           rayleigh_coefficient(nd_band)
!           Rayleigh coefficients
!
!str  fields for gaseous absorption:
      LOGICAL, Intent(IN) :: &
          l_gas
!           Include gas absorption in the calculation
!     gaseous overlaps:
      INTEGER, Intent(IN) :: &
          i_gas_overlap(nd_band) &
!           Gas overlap assumption
        , i_gas
!           Gas to be considered (one gas only)
!     ESFTs:
      INTEGER, Intent(IN) :: &
          n_band_absorb(nd_band) &
!           Number of absorbers in band
        , index_absorb(nd_species, nd_band) &
!           List of absorbers in bands
        , i_band_esft(nd_band, nd_species) &
!           Number of terms in band
        , i_scale_esft(nd_band, nd_species) &
!           Type of esft scaling
        , i_scale_fnc(nd_band, nd_species)
!           Type of scaling function
      REAL  (RealK), Intent(IN) :: &
          w_esft(nd_esft_term, nd_band, nd_species) &
!           Weights for ESFT
        , k_esft(nd_esft_term, nd_band, nd_species) &
!           Exponential ESFT terms
        , scale_vector(nd_scale_variable, nd_esft_term, nd_band &
              , nd_species) &
!           Absorber scaling parameters
        , p_reference(nd_species, nd_band) &
!           Reference scaling pressure
        , t_reference(nd_species, nd_band)
!           Reference scaling temperature
!
!str  Spectral data for the continuum:
      LOGICAL, Intent(IN) :: &
          l_continuum
!           Include continuum absorption in the calculation
      INTEGER, Intent(IN) :: &
          n_band_continuum(nd_band) &
!           Number of continua in bands
        , index_continuum(nd_band, nd_continuum) &
!           Indices of continua
        , index_water &
!           Index of water
        , i_scale_fnc_cont(nd_band, nd_continuum)
!           Type of scaling function for continuum
      REAL  (RealK), Intent(IN) :: &
          k_continuum(nd_band, nd_continuum) &
!           Continuum extinction coefficients
        , scale_continuum(nd_scale_variable, nd_band, nd_continuum) &
!           Continuum scaling parameters
        , p_ref_continuum(nd_continuum, nd_band) &
!           Continuum reference pressure
        , t_ref_continuum(nd_continuum, nd_band)
!           Continuum reference temperature
!
!
!str  General cloud fields:
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Clouds are required in the calculation
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Amount of cloud
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of different types of cloud
        , dp_corr_strat &
!           Decorrelation pressure scale for large scale cloud
        , dp_corr_conv
!           Decorrelation pressure scale for convective cloud
!
!str  Fields for microphysical quantities:
!
      LOGICAL, Intent(IN) :: &
          l_drop &
!           Include droplets in the calculation
        , l_ice &
!           Include ice in the calculation
        , l_global_cloud_top
!           Use a global value for the top of clouds
!           (This is for use in a GCM where the code must be
!           bit-reproducible across different configurations of PEs).
      INTEGER, Intent(IN) :: &
          n_condensed &
!           Number of condensed components in clouds
        , type_condensed(nd_cloud_component) &
!           Types of condensed components
        , i_condensed_param(nd_cloud_component) &
!           Parametrization schemes for components
        , condensed_n_phf(nd_cloud_component) &
!           Number of terms in the phase function
        , i_cloud_representation &
!           Representation of mixing rule chosen
        , n_cloud_type &
!           Number of types of cloud
        , n_global_cloud_top
!           Global cloud top
!
      REAL  (RealK), Intent(IN) :: &
          condensed_mix_ratio(nd_profile, id_ct: nd_layer &
            , nd_cloud_component) &
!           Mixing ratios of condensed components
        , condensed_dim_char(nd_profile, id_ct: nd_layer &
            , nd_cloud_component) &
!           Characteristic dimensions of condensed components
        , condensed_param_list(nd_cloud_parameter &
            , nd_cloud_component, nd_band)
!           Coefficients in parametrizations of condensed phases
!

!
!     Fields for prescribed optical properties of droplets
      INTEGER, Intent(IN) :: &
          n_opt_level_drop_prsc &
!           Number of levels of prescribed
!           optical properties of droplets
        , n_phase_term_drop_prsc
!           Number of terms in the phase function for prescribed
!           water droplets
      REAL  (RealK), Intent(IN) :: &
          drop_pressure_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Pressures at which optical properties of
!           droplets are prescribed
        , drop_absorption_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, nd_band) &
!           Prescribed absorption by droplets
        , drop_scattering_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, nd_band) &
!           Prescribed scattering by droplets
        , drop_phase_fnc_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, nd_phase_term, nd_band)
!           Prescribed phase function of droplets
!
!     Fields for prescribed optical properties of ice crystals
      INTEGER, Intent(IN) :: &
          n_opt_level_ice_prsc &
!           Number of levels of prescribed
!           optical properties of ice crystals
        , n_phase_term_ice_prsc
!           Number of terms in the phase function for prescribed
!           ice crystals
      REAL  (RealK), Intent(IN) :: &
          ice_pressure_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Pressures at which optical properties of
!           ice crystals are prescribed
        , ice_absorption_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, nd_band) &
!           Prescribed absorption by ice crystals
        , ice_scattering_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, nd_band) &
!           Prescribed scattering by ice crystals
        , ice_phase_fnc_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, nd_phase_term, nd_band)
!           Prescribed phase functions of ice crystals

!
!
!str  Fields for aerosols:
      LOGICAL, Intent(IN) :: &
          l_aerosol
!           Include aerosols in the calculation
      INTEGER, Intent(IN) :: &
          i_aerosol_parametrization(nd_aerosol_species) &
!           Parametrization flags for aerosol
        , n_aerosol_phf_term(nd_aerosol_species)
!           Number of terms in the phase function of aerosols
      INTEGER, Intent(IN) :: &
          nhumidity(nd_aerosol_species)
!           Number of humidities
      REAL  (RealK), Intent(IN) :: &
          aerosol_mix_ratio(nd_profile, nd_layer &
            , nd_aerosol_species)
!           Number density of aerosols
      REAL  (RealK), Intent(IN) :: &
          aerosol_absorption(nd_humidities, nd_aerosol_species &
            , nd_band) &
!           Absorption by aerosols
        , aerosol_scattering(nd_humidities, nd_aerosol_species &
              , nd_band) &
!           Scattering by aerosols
        , aerosol_phase_fnc(nd_humidities, nd_phase_term &
              , nd_aerosol_species, nd_band) &
!           Phase function of aerosols
        , humidities(nd_humidities, nd_aerosol_species)
!           Humidities for species
!

      INTEGER, Intent(IN) :: &
          n_opt_level_aerosol_prsc(nd_aerosol_species) &
!           Number of levels of prescribed optical properties
!           of aerosols
        , n_phase_term_aerosol_prsc(nd_aerosol_species)
!           Number of terms in the phase function for prescribed
!           aerosols
      REAL  (RealK), Intent(IN) :: &
          aerosol_pressure_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, nd_aerosol_species) &
!           Pressures at which optical properties of aerosols
!           are prescribed
        , aerosol_absorption_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, nd_aerosol_species, nd_band) &
!           Prescribed absorption by aerosols
        , aerosol_scattering_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, nd_aerosol_species, nd_band) &
!           Prescribed scattering by aerosols
        , aerosol_phase_fnc_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc &
            , nd_phase_term, nd_aerosol_species, nd_band)
!           Prescribed phase functions of aerosols

!
!str  Fitting of the Planckian function:
      INTEGER, Intent(IN) :: &
          n_deg_fit
!           Degree of thermal fitting fnc.
      REAL  (RealK), Intent(IN) :: &
          thermal_coefficient(0: nd_thermal_coeff-1, nd_band) &
!           Coefficients of source terms
        , t_ref_planck
!           Planckian reference temperature
!
!str  Doppler broadening
      LOGICAL, Intent(IN) :: &
          l_doppler(nd_species)
!           Flags to activate doppler corrections
      REAL  (RealK), Intent(IN) :: &
          doppler_correction(nd_species)
!           Doppler broadening term
      REAL  (RealK), Intent(IN) :: &
          weight_band(nd_band)
!           Weighting function for bands
!
!str  Control of scattering:
      INTEGER, Intent(IN) :: &
          i_scatter_method(nd_band)
!           Method of treating scattering in each band
!
!str  Fluxes or radiances calculated:
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer, nd_channel) &
!           Direct flux
        , flux_down(nd_flux_profile, 0: nd_layer, nd_channel) &
!           Downward flux
        , flux_up(nd_flux_profile, 0: nd_layer, nd_channel) &
!           Upward flux
        , flux_direct_clear(nd_2sg_profile, 0: nd_layer, nd_channel) &
!           Clear direct flux
        , flux_down_clear(nd_2sg_profile, 0: nd_layer, nd_channel) &
!           Clear downward flux
        , flux_up_clear(nd_2sg_profile, 0: nd_layer, nd_channel) &
!           Clear upward flux
        , radiance(nd_radiance_profile, nd_viewing_level &
            , nd_direction, nd_channel) &
!           Calculated radiances
        , photolysis(nd_j_profile, nd_viewing_level, nd_channel)
!           Rate of photolysis
      REAL  (RealK), Intent(OUT) :: &
          flux_up_tile(nd_point_tile, nd_tile, nd_channel) &
!           Upward fluxes at tiled surface points
        , flux_up_blue_tile(nd_point_tile, nd_tile, nd_channel)
!           Upward blue fluxes at tiled surface points
!
!str  Special Diagnostics:
      LOGICAL, Intent(IN) :: &
          l_blue_flux_surf
!           Flag to calculate the blue surface fluxes
      REAL  (RealK), Intent(IN) :: &
          weight_blue(nd_band)
!           Weights for each band for blue fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_blue_surf(nd_flux_profile) &
!           Direct blue flux at the surface
        , flux_down_blue_surf(nd_flux_profile) &
!           Total downward blue flux at the surface
        , flux_up_blue_surf(nd_flux_profile)
!           Upward blue flux at the surface
!
!
!
!     Local arguments.
!     General pointers:
      INTEGER &
          i_top &
!           Top level of profiles
        , i_band &
!           Spectral band
        , n_gas &
!           Number of active gases
        , i_gas_band &
!           Single variable for gas in band
        , n_continuum &
!           Number of continua in band
        , i_continuum &
!           Continuum number
        , i_continuum_pointer(nd_continuum) &
!           Pointers to continua

        , i_pointer_water
!           Pointer to water vapour

!
!     Additional variables for angular integration:
      LOGICAL &
          l_solar_phf &
!           Logical to specify a separate treatment of the singly
!           scattered solar beam
        , l_rescale_solar_phf
!           Logical to apply rescaling to the singly scattered
!           solar phase function
      INTEGER &
          n_order_phase &
!           Order of Legendre polynomials of the phase function
        , n_order_phase_solar
!           Order of Legendre polynomials of the phase function
!           retained for the singly scattered solar beam
!
!     Pointers to the contents of layers:
      INTEGER &
          n_cloud_top &
!           Topmost cloudy layer
        , n_region &
!           Number of cloudy regions
        , n_cloud_profile(id_ct: nd_layer) &
!           Number of cloudy profiles
        , i_cloud_profile(nd_profile, id_ct: nd_layer)
!           Profiles containing clouds
!
!     Pointers to types of clouds:
      LOGICAL &
          l_cloud_cmp(nd_cloud_component)
!           Logical switches to `include'' components
      INTEGER &
          i_phase_cmp(nd_cloud_component) &
!           Phases of components
        , i_cloud_type(nd_cloud_component) &
!           Pypes of cloud to which each component contributes
        , type_region(nd_region) &
!           The types of the regions
        , k_clr &
!           Index of clear-sky region
        , i_region_cloud(nd_cloud_type)
!           Regions in which particular type of cloud fall
!
!     Fractional coverage of different regions:
      REAL  (RealK) :: &
          frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fraction of total cloud occupied by specific regions
!
!     Pointer to table of humidities:
      INTEGER &
          i_humidity_pointer(nd_profile, nd_layer)
!           Pointer to look-up table for aerosols
!
!     Controlling variables:
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l
!           Loop variable
!
!     Logical switches:
      LOGICAL &
          l_gas_band &
!           Flag to `include'' gaseous absorption in a particular band
        , l_moist_aerosol &
!           Flag for moist aerosol
        , l_aerosol_density
!           Flag for calculation of atmospheric density for aerosols
!
      REAL  (RealK) :: &
          solar_irrad_band(nd_profile)
!           Solar irradiance in the band
      REAL  (RealK) :: &
          gas_frac_rescaled(nd_profile, nd_layer, nd_species) &
!           Rescaled gas mixing ratios
        , amount_continuum(nd_profile, nd_layer, nd_continuum) &
!           Amounts of continua
        , k_continuum_mono(nd_continuum)
!           Monochromatic continuum components
!
!     Thermal arrays:
      REAL  (RealK) :: &
          planck_flux_band(nd_profile, 0: nd_layer) &
!           Planckian flux in band at edges of layers
        , diff_planck_band(nd_profile, nd_layer) &
!           Difference in the Planckian flux across layers
        , diff_planck_band_2(nd_profile, nd_layer) &
!           Twice the 2nd difference of in the Planckian flux across
!           layers
        , planck_flux_ground(nd_profile)
!           Planckian flux at the surface temperature
!
!     Surface BRDF terms
      LOGICAL &
          l_diff_alb
!           Flag to calculate diffuse albedos
      REAL  (RealK) :: &
          brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
        , diffuse_alb_basis(nd_brdf_basis_fnc)
!           The diffuse albedo of isotropic radiation for each
!           basis function
!
!     Atmospheric densities:
      REAL  (RealK) :: &
          density(nd_profile, nd_layer) &
!           Overall density
        , molar_density_water(nd_profile, nd_layer) &
!           Molar density of water
        , molar_density_frn(nd_profile, nd_layer)
!           Molar density of foreign species
!
!     Fields for moist aerosols:
      REAL  (RealK) :: &
          delta_humidity &
!           Increment in look-up table for hum.
        , mean_rel_humidity(nd_profile, nd_layer)
!           Mean relative humidity of layers
!
!     Fundamental optical properties of layers:
      TYPE(STR_ss_prop) :: ss_prop
!       Single scattering properties of the atmosphere
!
!     Local variables for spherical harmonic integration
      INTEGER &
          ls_max_order &
!           Maximum order of terms required
        , ls_local_trunc(0: nd_max_order) &
!           Actual truncation for each particular value of m
        , ms_trunc(0: nd_max_order) &
!           Maximum azimuthal quantum number for each order
        , ia_sph_mm(0: nd_max_order)
!           Address of spherical coefficient of (m, m) for each m
      REAL  (RealK) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-gordon coefficients
        , uplm_zero(nd_sph_coeff) &
!           Upsilon terms
        , uplm_sol(nd_radiance_profile, nd_sph_coeff) &
!           Upsilon terms for solar radiation
        , cos_sol_view(nd_radiance_profile, nd_direction)
!           Cosines of the angles between the solar direction
!           and the viewing direction
!
!     Specification of the grid for radiances:
      INTEGER &
          i_rad_layer(nd_viewing_level)
!           Layers in which to intercept radiances
      REAL  (RealK) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
      REAL  (RealK) :: &
          i_direct(nd_radiance_profile, 0: nd_layer)
!           Direct solar irradiance on levels (not split by
!           diagnostic bands or returned, but retained for
!           future use)
      REAL  (RealK) :: &
          planck_radiance_band(nd_radiance_profile, nd_viewing_level)
!           Planckian radiance in the current band
      LOGICAL &
          l_initial
!           Flag to run the routine incrementing diagnostics in
!           its initializing mode
!
!     Coefficients for the transfer of energy between
!     Partially cloudy layers:
      REAL  (RealK) :: &
          cloud_overlap(nd_profile, id_ct-1: nd_layer &
            , nd_overlap_coeff) &
!           Coefficients defining overlapping options for clouds:
!           these also depend on the solver selected.
        , w_free(nd_profile, nd_layer)
!           Clear-sky fraction
!
!     Cloud geometry
      INTEGER &
          n_column_cld(nd_profile) &
!           Number of columns in each profile (including those of
!           zero width)
        , n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK) :: &
          area_column(nd_profile, nd_column)
!           Areas of columns

!hmjb - for vetorization on SX6
      REAL  (RealK) :: &
        zen_00(nd_profile, nd_layer)
!           Secant (two-stream) or cosine (spherical harmonics)
!           value repeated at every layer
!hmjb

!
!     Local variables for tiled fluxes:
      REAL  (RealK) :: &
          planck_flux_tile(nd_point_tile, nd_tile)
!           Local Planckian fluxes on surface tiles
!
!
!     Subroutines called:
!      EXTERNAL &
!          set_truncation, calc_cg_coeff, calc_uplm_zero &
!        , calc_uplm_sol, calc_brdf, sol_scat_cos, set_rad_layer &
!        , set_moist_aerosol_properties, set_cloud_pointer &
!        , set_cloud_geometry, aggregate_cloud &
!        , cloud_maxcs_split, overlap_coupled &
!        , calculate_density &
!        , scale_absorb, rescale_continuum, grey_opt_prop &
!        , rescale_phase_fnc, check_phf_term &
!        , diff_planck_source &
!        , solve_band_without_gas, solve_band_one_gas &
!        , solve_band_random_overlap, solve_band_k_eqv
!
!!     Functions called:
!      LOGICAL &
!          l_cloud_density
!!           Flag for calculation of atmospheric densities for clouds
!      EXTERNAL &
!          l_cloud_density
!
!
!
!

!hmjb - Prepare for vetorization
      DO i=1,nd_layer
         DO l=1,nd_profile
            zen_00(l, i)=zen_0(l)
         ENDDO
      ENDDO
!hmjb

!
!     Initial determination of flags and switches:
!
      IF (i_angular_integration == IP_two_stream) THEN
!
!       Only one term in the phase function is required.
        n_order_phase=1
!
        l_solar_phf=.false.
        l_rescale_solar_phf=.false.
!
      ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
!       Set limits on ranges of harmonics and set pointers to arrays.
        CALL set_truncation(ierr &
          , i_truncation, ls_global_trunc &
          , ls_max_order, ls_local_trunc &
          , ms_min, ms_max, ms_trunc &
          , ia_sph_mm, n_order_phase &
          , nd_max_order &
          )
!
!       Determine whether special treatment of the solar
!       beam is required.
        l_solar_phf=(isolir == IP_solar).AND. &
                    (i_sph_algorithm == IP_sph_reduced_iter)
        l_rescale_solar_phf=l_rescale.AND.l_solar_phf
!       Calculate the solar scattering angles if treating the
!       solar beam separately.
        IF (l_solar_phf) THEN
          CALL sol_scat_cos(n_profile, n_direction &
            , zen_0, direction, cos_sol_view &
            , nd_profile, nd_direction)
        ENDIF
!
!       Calculate Clebsch-Gordan coefficients once and for all.
        CALL calc_cg_coeff(ls_max_order &
          , ia_sph_mm, ms_min, ms_trunc &
          , cg_coeff &
          , nd_max_order, nd_sph_coeff)
!
!       Calculate spherical harmonics at polar angles of pi/2 for
!       use in Marshak''s boundary conditions.
        CALL calc_uplm_zero(ms_min, ms_max, ia_sph_mm &
          , ls_local_trunc, uplm_zero &
          , nd_max_order, nd_sph_coeff)
!
        IF (isolir == IP_solar) THEN
!         Calculate the spherical harmonics of the solar direction.
          CALL calc_uplm_sol(n_profile, ms_min, ms_max, ia_sph_mm &
            , ls_local_trunc, zen_0, uplm_sol &
            , nd_profile, nd_max_order, nd_sph_coeff)
        ENDIF
!
        IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
!         Calcuate some arrays of terms for the BRDF.
          CALL calc_brdf(isolir, ms_min, ms_max, ia_sph_mm &
            , uplm_sol, uplm_zero &
            , n_brdf_basis_fnc, ls_brdf_trunc, f_brdf &
            , n_profile, n_direction, direction &
            , brdf_sol, brdf_hemi &
            , nd_profile, nd_radiance_profile, nd_direction &
            , nd_max_order, nd_sph_coeff &
            , nd_brdf_basis_fnc, nd_brdf_trunc)
        ENDIF
!
!       For the calculation of equivalent extinction in the IR
!       we need the diffuse albedo for each basis function.
        l_diff_alb=.false.
        DO i_band=1, n_band
          l_diff_alb=l_diff_alb.OR. &
            (i_gas_overlap(i_band) == IP_overlap_k_eqv)
        ENDDO
        IF ( (isolir == IP_infra_red).AND.l_diff_alb ) THEN
          CALL diff_albedo_basis(n_brdf_basis_fnc &
            , ls_brdf_trunc, f_brdf &
            , uplm_zero(ia_sph_mm(0)) &
            , diffuse_alb_basis &
            , nd_brdf_basis_fnc, nd_brdf_trunc, nd_sph_coeff &
            )
        ENDIF
!
!       Determine which layers will be required to give radiances.
        CALL set_rad_layer(ierr &
          , n_layer, n_viewing_level, viewing_level &
          , i_rad_layer, frac_rad_layer &
          , nd_viewing_level &
          )
!
!
      ENDIF
!
!     Set the top level of the profiles. This is currently reatined
!     for historical reasons.
      i_top=1
!
!
!
!     Initial calculations for aerosols:
!
!     Set the spectrally independent properties of moist aerosols.
      l_moist_aerosol=.false.
      DO j=1, n_aerosol
        l_moist_aerosol=l_moist_aerosol.OR. &
          (i_aerosol_parametrization(j) &
           == IP_aerosol_param_moist)
      ENDDO
!
      IF (l_moist_aerosol) THEN
        CALL set_moist_aerosol_properties(ierr &
          , n_profile, n_layer &
          , n_aerosol, i_aerosol_parametrization, nhumidity &
          , gas_mix_ratio(1, 1, index_water), t, p, delta_humidity &
          , mean_rel_humidity, i_humidity_pointer &
          , nd_profile, nd_layer, nd_aerosol_species &
          )
        IF (ierr /= i_normal) RETURN
      ENDIF
!
!
!     Check whether the densities will be needed for
!     unparametrized aerosols.
      l_aerosol_density=.false.
      IF (l_aerosol) THEN
        DO j=1, n_aerosol
          l_aerosol_density=l_aerosol_density.OR. &
            (i_aerosol_parametrization(j) == &
             IP_aerosol_param_moist) &
             .OR.(i_aerosol_parametrization(j) == &
             IP_aerosol_unparametrized)
        ENDDO
      ENDIF
!
!
!
!     Initial calculations for clouds:
!
      IF (l_cloud) THEN
!
!       Set pointers to the types of cloud.
        CALL set_cloud_pointer(ierr &
          , n_condensed, type_condensed, i_cloud_representation &
          , l_drop, l_ice &
          , i_phase_cmp, i_cloud_type, l_cloud_cmp &
          , nd_cloud_component &
          )
        IF (ierr /= i_normal) RETURN
!
!
!       Set the geometry of the clouds.
        CALL set_cloud_geometry(n_profile, n_layer &
          , l_global_cloud_top, n_global_cloud_top, w_cloud &
          , n_cloud_top, n_cloud_profile, i_cloud_profile &
          , nd_profile, nd_layer, id_ct &
          )
!
        k_clr=1
        IF ( (i_cloud == IP_cloud_triple).OR. &
             (i_cloud == IP_cloud_part_corr_cnv) ) THEN
!         Aggregate clouds into regions for solving.
!         Three regions are used with this option. Additionally,
!         flag the clear-sky region.
          n_region=3
          type_region(1)=IP_region_clear
          type_region(2)=IP_region_strat
          type_region(3)=IP_region_conv
          CALL aggregate_cloud(ierr &
            , n_profile, n_layer, n_cloud_top &
            , i_cloud, i_cloud_representation &
            , n_cloud_type, frac_cloud &
            , i_region_cloud, frac_region &
            , nd_profile, nd_layer, nd_cloud_type, nd_region &
            , id_ct &
            )
        ELSE IF ( (i_cloud == IP_cloud_mix_max).OR. &
                  (i_cloud == IP_cloud_mix_random).OR. &
                  (i_cloud == IP_cloud_part_corr) ) THEN
!         There will be only one cloudy region.
          n_region=2
          type_region(1)=IP_region_clear
          type_region(2)=IP_region_strat
          DO i=n_cloud_top, n_layer
            DO l=1, n_profile
              frac_region(l, i, 2)=1.0e+00_RealK
            ENDDO
          ENDDO
        ENDIF
!
!       Calculate energy transfer coefficients in a mixed column,
!       or split the atmosphere into columns with a column model:
!
        IF ( (i_cloud == IP_cloud_mix_max).OR. &
             (i_cloud == IP_cloud_mix_random).OR. &
             (i_cloud == IP_cloud_triple).OR. &
             (i_cloud == IP_cloud_part_corr).OR. &
             (i_cloud == IP_cloud_part_corr_cnv) ) THEN
!
          CALL overlap_coupled(n_profile, n_layer, n_cloud_top &
            , w_cloud, w_free, n_region, type_region, frac_region, p &
            , i_cloud &
            , cloud_overlap &
            , nd_profile, nd_layer, nd_overlap_coeff, nd_region &
            , id_ct, dp_corr_strat, dp_corr_conv &
            )
!
        ELSE IF (i_cloud == IP_cloud_column_max) THEN
!
            CALL cloud_maxcs_split(ierr, n_profile, n_layer, n_cloud_top &
              , w_cloud, frac_cloud &
              , n_cloud_type &
              , n_column_cld, n_column_slv, list_column_slv &
              , i_clm_lyr_chn, i_clm_cld_typ, area_column &
              , nd_profile, nd_layer, id_ct, nd_column, nd_cloud_type &
              )
!
        ENDIF
!
      ELSE
!
        n_cloud_top=n_layer+1
!
      ENDIF
!
!
!     Calculate the atmospheric densities:
!
      IF ( l_continuum &
            .OR.l_aerosol_density &
            .OR.(l_cloud &
            .AND.l_cloud_density(n_condensed, i_phase_cmp, l_cloud_cmp &
                              , i_condensed_param, nd_cloud_component &
                              ) ) ) THEN

!       Set the pointer for water vapour to a legal value: this must
!       be done for cases where water vapour is not included in the
!       spectral file, but densities are needed for aerosols.
        i_pointer_water=max(index_water, 1)

        CALL calculate_density(n_profile, n_layer, l_continuum &




          , gas_mix_ratio(1, 1, i_pointer_water) &

          , p, t, i_top &
          , density, molar_density_water, molar_density_frn &
          , nd_profile, nd_layer &
          )
      ENDIF
!
!
!     Check that there is enough information in the case of spherical
!     harmonics. This check is rather late in the logical order of
!     things, but we had to wait for certain other calculations to be
!     made.
      IF (i_angular_integration == IP_spherical_harmonic) THEN
        CALL check_phf_term(ierr &
          , l_aerosol, n_aerosol, i_aerosol_parametrization &
          , n_aerosol_phf_term &

          , n_phase_term_aerosol_prsc &

          , l_cloud, n_condensed, i_condensed_param, i_phase_cmp &
          , condensed_n_phf &

          , n_phase_term_drop_prsc, n_phase_term_ice_prsc &

          , n_order_phase, l_henyey_greenstein_pf &
          , l_rescale, n_order_forward &
          , l_solar_phf, n_order_phase_solar &
          , nd_aerosol_species, nd_cloud_component &
          )
        IF (ierr /= i_normal) RETURN
      ENDIF
!
!
!
!
!
!     Solve the equation of transfer in each band and
!     increment the fluxes.
!
      DO i_band=i_first_band, i_last_band
!
!       Set the flag to initialize the diagnostic arrays.
        IF (i_band == i_first_band) THEN
          l_initial=.true.
        ELSE
          l_initial=(map_channel(i_band) > map_channel(i_band-1))
        ENDIF
!
!
!       Determine whether gaseous absorption is included in this band.
        IF ( (l_gas).AND.(n_band_absorb(i_band) > 0) ) THEN
!
!         Note: I_GAS_BAND is used extensively below since nested
!         array elements in a subroutine call (see later) can
!         confuse some compilers.
!
!         Normally the number of gases in the calculation will be
!         as in the spectral file, but particular options may result
!         in the omission of some gases.
!
          n_gas=n_band_absorb(i_band)
!
          IF (i_gas_overlap(i_band) == IP_overlap_single) THEN
!
!           There will be no gaseous absorption in this band
!           unless the selected gas appears.
            n_gas=0
!
            DO i=1, n_band_absorb(i_band)
              IF (index_absorb(i, i_band) == i_gas) n_gas=1
            ENDDO
!
          ENDIF
!
!
          IF (n_gas > 0) THEN
!
!           Set the flag for gaseous absorption in the band.
            l_gas_band=.true.
!
            DO j=1, n_gas
!
              i_gas_band=index_absorb(j, i_band)
!
!             Reset the pointer if there is just one gas.
!
              IF (i_gas_overlap(i_band) == IP_overlap_single) &
                THEN
!               Only the selected gas is active in the band.
                i_gas_band=i_gas
!
              ENDIF
!
              IF (i_scale_esft(i_band, i_gas_band) &
                  == IP_scale_band) THEN
!               Rescale the amount of gas for this band now.
                CALL scale_absorb(ierr, n_profile, n_layer &
                  , gas_mix_ratio(1, 1, i_gas_band), p, t &
                  , i_top &
                  , gas_frac_rescaled(1, 1, i_gas_band) &
                  , i_scale_fnc(i_band, i_gas_band) &
                  , p_reference(i_gas_band, i_band) &
                  , t_reference(i_gas_band, i_band) &
                  , scale_vector(1, 1, i_band, i_gas_band) &
                  , l_doppler(i_gas_band) &
                  , doppler_correction(i_gas_band) &
                  , nd_profile, nd_layer &
                  , nd_scale_variable &
                  )
                IF (ierr /= i_normal) RETURN
!
              ELSE IF (i_scale_esft(i_band, i_gas_band) &
                  == IP_scale_null) THEN
!               Copy across the unscaled array.
                DO i=i_top, n_layer
                  DO l=1, n_profile
                    gas_frac_rescaled(l, i, i_gas_band) &
                      =gas_mix_ratio(l, i, i_gas_band)
                  ENDDO
                ENDDO
              ENDIF
            ENDDO
          ELSE
            l_gas_band=.false.
          ENDIF
!
        ELSE
          l_gas_band=.false.
        ENDIF
!
!
!
!       Rescale amounts of continua.
!
        IF (l_continuum) THEN
          n_continuum=n_band_continuum(i_band)
          DO i=1, n_continuum
            i_continuum_pointer(i)=index_continuum(i_band, i)
            i_continuum=i_continuum_pointer(i)
            k_continuum_mono(i_continuum) &
              =k_continuum(i_band, i_continuum)
            CALL rescale_continuum(n_profile, n_layer, i_continuum &
              , p, t, i_top &
              , density, molar_density_water, molar_density_frn &
              , gas_mix_ratio(1, 1, index_water) &
              , amount_continuum(1, 1, i_continuum) &
              , i_scale_fnc_cont(i_band, i_continuum) &
              , p_ref_continuum(i_continuum, i_band) &
              , t_ref_continuum(i_continuum, i_band) &
              , scale_continuum(1, i_band, i_continuum) &
              , nd_profile, nd_layer &
              , nd_scale_variable &
              )
          ENDDO
        ENDIF
!
!       Allocate the single scattering propeties.
!
        ALLOCATE(ss_prop%k_grey_tot_clr &
          (nd_profile, 1:nd_layer_clr))
        ALLOCATE(ss_prop%k_ext_scat_clr &
          (nd_profile, 1:nd_layer_clr))
        ALLOCATE(ss_prop%tau_clr &
          (nd_profile, 1:nd_layer_clr))
        ALLOCATE(ss_prop%omega_clr &
          (nd_profile, 1:nd_layer_clr))
        ALLOCATE(ss_prop%phase_fnc_clr &
          (nd_profile, 1:nd_layer_clr, nd_max_order))
        ALLOCATE(ss_prop%forward_scatter_clr &
          (nd_profile, 1:nd_layer_clr))
        ALLOCATE(ss_prop%forward_solar_clr &
          (nd_profile, 1:nd_layer_clr))
        ALLOCATE(ss_prop%phase_fnc_solar_clr &
          (nd_profile, 1:nd_layer_clr, nd_direction))
!
        ALLOCATE(ss_prop%k_grey_tot &
          (nd_profile, id_ct: nd_layer, 0: nd_cloud_type))
        ALLOCATE(ss_prop%k_ext_scat &
          (nd_profile, id_ct: nd_layer, 0: nd_cloud_type))
        ALLOCATE(ss_prop%tau &
          (nd_profile, id_ct: nd_layer, 0: nd_cloud_type))
        ALLOCATE(ss_prop%omega &
          (nd_profile, id_ct: nd_layer, 0: nd_cloud_type))
        ALLOCATE(ss_prop%phase_fnc &
          (nd_profile, id_ct: nd_layer, nd_max_order &
          , 0: nd_cloud_type))
        ALLOCATE(ss_prop%forward_scatter &
          (nd_profile, id_ct: nd_layer, 0: nd_cloud_type))
        ALLOCATE(ss_prop%forward_solar &
          (nd_profile, id_ct: nd_layer, 0: nd_cloud_type))
        ALLOCATE(ss_prop%phase_fnc_solar &
          (nd_profile, id_ct: nd_layer, nd_direction &
          , 0: nd_cloud_type))
!
!
!
!       Calculate the grey extinction within the band.
!
        CALL grey_opt_prop(ierr &
          , n_profile, n_layer, p, t, density &
          , n_order_phase, l_rescale, n_order_forward &
          , l_henyey_greenstein_pf, l_solar_phf, n_order_phase_solar &
          , n_direction, cos_sol_view &
          , l_rayleigh, rayleigh_coefficient(i_band) &
          , l_continuum, n_continuum, i_continuum_pointer &
          , k_continuum_mono, amount_continuum &
          , l_aerosol, n_aerosol, aerosol_mix_ratio &
          , i_aerosol_parametrization &
          , i_humidity_pointer, humidities, delta_humidity &
          , mean_rel_humidity &
          , aerosol_absorption(1, 1, i_band) &
          , aerosol_scattering(1, 1, i_band) &
          , aerosol_phase_fnc(1, 1, 1, i_band) &

          , n_opt_level_aerosol_prsc, aerosol_pressure_prsc &
          , aerosol_absorption_prsc(1, 1, 1, i_band) &
          , aerosol_scattering_prsc(1, 1, 1, i_band) &
          , aerosol_phase_fnc_prsc(1, 1, 1, 1, i_band) &

          , l_cloud, n_cloud_profile, i_cloud_profile, n_cloud_top &
          , n_condensed, l_cloud_cmp, i_phase_cmp &
          , i_condensed_param &
          , condensed_param_list(1, 1, i_band) &
          , condensed_mix_ratio, condensed_dim_char &
          , n_cloud_type, i_cloud_type &

          , n_opt_level_drop_prsc, drop_pressure_prsc &
          , drop_absorption_prsc(1, 1, i_band) &
          , drop_scattering_prsc(1, 1, i_band) &
          , drop_phase_fnc_prsc(1, 1, 1, i_band) &
          , n_opt_level_ice_prsc, ice_pressure_prsc &
          , ice_absorption_prsc(1, 1, i_band) &
          , ice_scattering_prsc(1, 1, i_band) &
          , ice_phase_fnc_prsc(1, 1, 1, i_band) &

          , ss_prop &
          , nd_profile, nd_radiance_profile, nd_layer &
          , nd_layer_clr, id_ct &
          , nd_continuum, nd_aerosol_species, nd_humidities &
          , nd_cloud_parameter, nd_cloud_component &
          , nd_phase_term, nd_max_order, nd_direction &

          , nd_profile_aerosol_prsc, nd_profile_cloud_prsc &
          , nd_opt_level_aerosol_prsc, nd_opt_level_cloud_prsc &

          )
        IF (ierr /= i_normal) RETURN
!
!
        IF ( (i_angular_integration == IP_two_stream).OR. &
             (i_angular_integration == IP_spherical_harmonic) ) THEN
!
!         Rescale the phase function and calculate the scattering
!         fractions. (These are grey and may be calculated outside
!         a loop over gases).
!
          IF (l_rescale) THEN
!
!           Rescale clear-sky phase function:
!
!           The section above clouds.
!hmjb            CALL rescale_phase_fnc(n_profile, 1, n_cloud_top-1 &
!hmjb              , n_direction, cos_sol_view &
!hmjb              , n_order_phase &
!hmjb              , ss_prop%phase_fnc_clr, ss_prop%forward_scatter_clr &
!hmjb              , ss_prop%forward_solar_clr &
!hmjb              , l_rescale_solar_phf, n_order_phase_solar &
!hmjb              , ss_prop%phase_fnc_solar_clr &
!hmjb              , nd_profile, nd_radiance_profile, nd_layer_clr, 1 &
!hmjb              , nd_direction, nd_max_order &
!hmjb              )
!hmjb!           The section including clouds.
!hmjb            CALL rescale_phase_fnc(n_profile, n_cloud_top &
!hmjb              , n_layer, n_direction, cos_sol_view &
!hmjb              , n_order_phase &
!hmjb!hmjb              , ss_prop%phase_fnc(1, id_ct, 1, 0) &
!hmjb              , ss_prop%phase_fnc(:, :, :, 0) &
!hmjb              , ss_prop%forward_scatter(:, :, 0) &
!hmjb              , ss_prop%forward_solar(:, :, 0) &
!hmjb              , l_rescale_solar_phf, n_order_phase_solar &
!hmjb              , ss_prop%phase_fnc_solar(:, :, :, 0) &
!hmjb              , nd_profile, nd_radiance_profile, nd_layer, id_ct &
!hmjb              , nd_direction, nd_max_order &
!hmjb              )
!
!
            IF (l_cloud) THEN
!
!             Rescale cloudy phase functions:
!
!CDIR COLLAPSE
              DO k=0, n_cloud_type
                CALL rescale_phase_fnc(n_profile, 1 &
                  , n_layer, n_direction, cos_sol_view &
                  , n_order_phase &
                  , ss_prop%phase_fnc(:, :, :, k) &
                  , ss_prop%forward_scatter(:, :, k) &
                  , ss_prop%forward_solar(:, :, k) &
                  , l_rescale_solar_phf, n_order_phase_solar &
                  , ss_prop%phase_fnc_solar(:, :, :, k) &
                  , nd_profile, nd_radiance_profile, nd_layer, id_ct &
                  , nd_direction, nd_max_order &
                  )
              ENDDO
            ELSE
              CALL rescale_phase_fnc(n_profile, 1 &
                , n_layer, n_direction, cos_sol_view &
                , n_order_phase &
                , ss_prop%phase_fnc(:, :, :, 0) &
                , ss_prop%forward_scatter(:, :, 0) &
                , ss_prop%forward_solar(:, :, 0) &
                , l_rescale_solar_phf, n_order_phase_solar &
                , ss_prop%phase_fnc_solar(:, :, :, 0) &
                , nd_profile, nd_radiance_profile, nd_layer, id_ct &
                , nd_direction, nd_max_order &
                )
!
            ENDIF
!
          ENDIF
!
        ENDIF
!
!
!
!
!       Preliminary calculations for source terms:
!
        IF (isolir == IP_solar) THEN
!         Convert normalized band fluxes to actual energy fluxes.
          DO l=1, n_profile
            solar_irrad_band(l)=solar_irrad(l) &
              *solar_flux_band(i_band)
          ENDDO
!
        ELSE IF (isolir == IP_infra_red) THEN
!
!         Calculate the change in the thermal source function
!         across each layer for the infra-red part of the spectrum.
!
          CALL diff_planck_source(n_profile, n_layer &
            , n_deg_fit, thermal_coefficient(0, i_band) &
            , t_ref_planck, t_level, t_ground &
            , planck_flux_band, diff_planck_band &
            , planck_flux_ground &
            , l_ir_source_quad, t, diff_planck_band_2 &
            , i_angular_integration &
            , n_viewing_level, i_rad_layer, frac_rad_layer &
            , planck_radiance_band &
            , l_tile, n_point_tile, n_tile, list_tile &
            , frac_tile, t_tile, planck_flux_tile &
            , nd_profile, nd_layer, nd_thermal_coeff &
            , nd_radiance_profile, nd_viewing_level &
            , nd_point_tile, nd_tile &
            )
!
        ENDIF
!
!
!
!
!
!
!       Call a solver appropriate to the presence of gases and
!       the overlap assumed:
!
        IF (.NOT.l_gas_band) THEN
!
!         There is no gaseous absorption. Solve for the
!         radiances directly.
!
          CALL solve_band_without_gas(ierr &
!                        Atmospheric properties
            , n_profile, n_layer, d_mass &
!                        Angular integration
            , i_angular_integration, i_2stream &
            , n_order_phase, l_rescale, n_order_gauss &
            , ms_min, ms_max, i_truncation, ls_local_trunc &
            , accuracy_adaptive, euler_factor, i_sph_algorithm &
            , i_sph_mode &
!                        Precalculated angular arrays
            , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
            , i_scatter_method(i_band) &
!                        Options for solver
            , i_solver &
!                        Spectral region
            , isolir &
!                        Solar properties
            , zen_0, zen_00, solar_irrad_band & !hmjb
!                        Infra-red properties
            , planck_flux_band(1, 0), planck_flux_band(1, n_layer) &
            , diff_planck_band, l_ir_source_quad, diff_planck_band_2 &
!                        Surface properties
            , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb(1, 1, i_band) &
            , f_brdf, brdf_sol, brdf_hemi &
            , planck_flux_ground &
!                       Tiling of the surface
            , l_tile, n_point_tile, n_tile, list_tile &
            , rho_alb_tile(1, 1, 1, i_band), planck_flux_tile &
!                       Optical Properties
            , ss_prop &
!                        Cloudy properties
            , l_cloud, i_cloud &
!                        Cloudy geometry
            , n_cloud_top &
            , n_cloud_type, frac_cloud &
            , n_region, k_clr, i_region_cloud, frac_region &
            , w_free, w_cloud, cloud_overlap &
            , n_column_slv, list_column_slv &
            , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                      Levels for calculating radiances
            , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
            , n_direction, direction &
!                        Weighting factor for the band
            , weight_band(i_band), l_initial &
!                        Calculated fluxes
            , flux_direct(1, 0, map_channel(i_band)) &
            , flux_down(1, 0, map_channel(i_band)) &
            , flux_up(1, 0, map_channel(i_band)) &
!                        Radiances
            , i_direct, radiance(1, 1, 1, map_channel(i_band)) &
!                        Rate of photolysis
            , photolysis(1, 1, map_channel(i_band)) &
!                        Flags for clear-sky fluxes
            , l_clear, i_solver_clear &
!                        Calculated clear-sky fluxes
            , flux_direct_clear(1, 0, map_channel(i_band)) &
            , flux_down_clear(1, 0, map_channel(i_band)) &
            , flux_up_clear(1, 0, map_channel(i_band)) &
!                       Tiled Surface Fluxes
            , flux_up_tile(1, 1, map_channel(i_band)) &
            , flux_up_blue_tile(1, 1, map_channel(i_band)) &
!                       Special Surface Fluxes
            , l_blue_flux_surf, weight_blue(i_band) &
            , flux_direct_blue_surf &
            , flux_down_blue_surf, flux_up_blue_surf &
!                        Dimensions of arrays
            , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
            , nd_flux_profile, nd_radiance_profile, nd_j_profile &
            , nd_cloud_type, nd_region, nd_overlap_coeff &
            , nd_max_order, nd_sph_coeff &
            , nd_brdf_basis_fnc, nd_brdf_trunc &
            , nd_viewing_level, nd_direction &
            , nd_source_coeff, nd_point_tile, nd_tile &
            )
          IF (ierr /= i_normal) RETURN
!
!
        ELSE
!
!         Gases are included.
!
!         Treat the gaseous overlaps as directed by
!         the overlap switch.
!
          IF (i_gas_overlap(i_band) == IP_overlap_single) THEN
!
            CALL solve_band_one_gas(ierr &
!                        Atmospheric properties
              , n_profile, n_layer, i_top, p, t, d_mass &
!                        Angular integration
              , i_angular_integration, i_2stream &
              , n_order_phase, l_rescale, n_order_gauss &
              , ms_min, ms_max, i_truncation, ls_local_trunc &
              , accuracy_adaptive, euler_factor &
              , i_sph_algorithm, i_sph_mode &
!                        Precalculated angular arrays
              , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
              , i_scatter_method(i_band) &
!                        Options for solver
              , i_solver &
!                        Gaseous properties
              , i_band, i_gas &
              , i_band_esft, i_scale_esft, i_scale_fnc &
              , k_esft, w_esft, scale_vector &
              , p_reference, t_reference &
              , gas_mix_ratio, gas_frac_rescaled &
              , l_doppler, doppler_correction &
!                        Spectral region
              , isolir &
!                        Solar properties
              , zen_0, zen_00, solar_irrad_band & !hmjb
!                        Infra-red properties
              , planck_flux_band(1, 0) &
              , planck_flux_band(1, n_layer) &
              , diff_planck_band &
              , l_ir_source_quad, diff_planck_band_2 &
!                        Surface properties
              , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb(1, 1, i_band) &
              , f_brdf, brdf_sol, brdf_hemi &
              , planck_flux_ground &
!                       Tiling of the surface
              , l_tile, n_point_tile, n_tile, list_tile &
              , rho_alb_tile(1, 1, 1, i_band) &
              , planck_flux_tile &
!                       Optical Properties
              , ss_prop &
!                        Cloudy properties
              , l_cloud, i_cloud &
!                        Cloud geometry
              , n_cloud_top &
              , n_cloud_type, frac_cloud &
              , n_region, k_clr, i_region_cloud, frac_region &
              , w_free, w_cloud, cloud_overlap &
              , n_column_slv, list_column_slv &
              , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
              , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
              , n_direction, direction &
!                        Weighting factor for the band
              , weight_band(i_band), l_initial &
!                        Fluxes calculated
              , flux_direct(1, 0, map_channel(i_band)) &
              , flux_down(1, 0, map_channel(i_band)) &
              , flux_up(1, 0, map_channel(i_band)) &
!                        Radiances
              , i_direct, radiance(1, 1, 1, map_channel(i_band)) &
!                        Rate of photolysis
              , photolysis(1, 1, map_channel(i_band)) &
!                        Flags for clear-sky calculations
              , l_clear, i_solver_clear &
!                        Clear-sky fluxes
              , flux_direct_clear(1, 0, map_channel(i_band)) &
              , flux_down_clear(1, 0, map_channel(i_band)) &
              , flux_up_clear(1, 0, map_channel(i_band)) &
!                       Tiled Surface Fluxes
              , flux_up_tile(1, 1, map_channel(i_band)) &
              , flux_up_blue_tile(1, 1, map_channel(i_band)) &
!                       Special Surface Fluxes
              , l_blue_flux_surf, weight_blue(i_band) &
              , flux_direct_blue_surf &
              , flux_down_blue_surf, flux_up_blue_surf &
!                        Dimensions of arrays
              , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
              , nd_flux_profile, nd_radiance_profile, nd_j_profile &
              , nd_band, nd_species &
              , nd_esft_term, nd_scale_variable &
              , nd_cloud_type, nd_region, nd_overlap_coeff &
              , nd_max_order, nd_sph_coeff &
              , nd_brdf_basis_fnc, nd_brdf_trunc &
              , nd_viewing_level, nd_direction &
              , nd_source_coeff, nd_point_tile, nd_tile &
              )
!
          ELSE IF (i_gas_overlap(i_band) == IP_overlap_random) THEN
!
            CALL solve_band_random_overlap(ierr &
!                        Atmospheric properties
              , n_profile, n_layer, i_top, p, t, d_mass &
!                        Angular integration
              , i_angular_integration, i_2stream &
              , n_order_phase, l_rescale, n_order_gauss &
              , ms_min, ms_max, i_truncation, ls_local_trunc &
              , accuracy_adaptive, euler_factor &
              , i_sph_algorithm, i_sph_mode &
!                        Precalculated angular arrays
              , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
              , i_scatter_method(i_band) &
!                        Options for solver
              , i_solver &
!                        Gaseous properties
              , i_band, n_gas &
              , index_absorb, i_band_esft, i_scale_esft, i_scale_fnc &
              , k_esft, w_esft, scale_vector &
              , p_reference, t_reference &
              , gas_mix_ratio, gas_frac_rescaled &
              , l_doppler, doppler_correction &
!                        Spectral region
              , isolir &
!                        Solar properties
              , zen_0, zen_00, solar_irrad_band & !hmjb
!                        Infra-red properties
              , planck_flux_band(1, 0) &
              , planck_flux_band(1, n_layer) &
              , diff_planck_band &
              , l_ir_source_quad, diff_planck_band_2 &
!                        Surface properties
              , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb(1, 1, i_band) &
              , f_brdf, brdf_sol, brdf_hemi &
              , planck_flux_ground &
!                       Tiling of the surface
              , l_tile, n_point_tile, n_tile, list_tile &
              , rho_alb_tile(1, 1, 1, i_band) &
              , planck_flux_tile &
!                       Optical Properties
              , ss_prop &
!                        Cloudy properties
              , l_cloud, i_cloud &
!                        Cloud geometry
              , n_cloud_top &
              , n_cloud_type, frac_cloud &
              , n_region, k_clr, i_region_cloud, frac_region &
              , w_free, w_cloud, cloud_overlap &
              , n_column_slv, list_column_slv &
              , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
              , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
              , n_direction, direction &
!                        Weighting factor for the band
              , weight_band(i_band), l_initial &
!                        Fluxes calculated
              , flux_direct(1, 0, map_channel(i_band)) &
              , flux_down(1, 0, map_channel(i_band)) &
              , flux_up(1, 0, map_channel(i_band)) &
!                        Radiances
              , i_direct, radiance(1, 1, 1, map_channel(i_band)) &
!                        Rate of photolysis
              , photolysis(1, 1, map_channel(i_band)) &
!                        Flags for clear-sky calculations
              , l_clear, i_solver_clear &
!                        Clear-sky fluxes
              , flux_direct_clear(1, 0, map_channel(i_band)) &
              , flux_down_clear(1, 0, map_channel(i_band)) &
              , flux_up_clear(1, 0, map_channel(i_band)) &
!                       Tiled Surface Fluxes
              , flux_up_tile(1, 1, map_channel(i_band)) &
              , flux_up_blue_tile(1, 1, map_channel(i_band)) &
!                       Special Surface Fluxes
              , l_blue_flux_surf, weight_blue(i_band) &
              , flux_direct_blue_surf &
              , flux_down_blue_surf, flux_up_blue_surf &
!                        Dimensions of arrays
              , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
              , nd_flux_profile, nd_radiance_profile, nd_j_profile &
              , nd_band, nd_species &
              , nd_esft_term, nd_scale_variable &
              , nd_cloud_type, nd_region, nd_overlap_coeff &
              , nd_max_order, nd_sph_coeff &
              , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
              , nd_direction, nd_source_coeff, nd_point_tile, nd_tile &
              )
!
          ELSE IF (i_gas_overlap(i_band) == IP_overlap_k_eqv) THEN
!
            CALL solve_band_k_eqv(ierr &
!                        Atmospheric properties
              , n_profile, n_layer, i_top, p, t, d_mass &
!                        Angular integration
              , i_angular_integration, i_2stream &
              , n_order_phase, l_rescale, n_order_gauss &
              , ms_min, ms_max, i_truncation, ls_local_trunc &
              , accuracy_adaptive, euler_factor &
              , i_sph_algorithm, i_sph_mode &
!                        Precalculated angular arrays
              , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
              , i_scatter_method(i_band) &
!                        Options for solver
              , i_solver &
!                        Gaseous properties
              , i_band, n_gas &
              , index_absorb, i_band_esft, i_scale_esft, i_scale_fnc &
              , k_esft, w_esft, scale_vector &
              , p_reference, t_reference &
              , gas_mix_ratio, gas_frac_rescaled &
              , l_doppler, doppler_correction &
!                        Spectral region
              , isolir &
!                        Solar properties
              , zen_0, zen_00, solar_irrad_band & !hmjb
!                        Infra-red properties
              , planck_flux_band &
              , diff_planck_band &
              , l_ir_source_quad, diff_planck_band_2 &
!                        Surface properties
              , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb(1, 1, i_band) &
              , f_brdf, brdf_sol, brdf_hemi &
              , diffuse_alb_basis &
              , planck_flux_ground &
!                       Tiling of the surface
              , l_tile, n_point_tile, n_tile, list_tile &
              , rho_alb_tile(1, 1, 1, i_band) &
              , planck_flux_tile &
!                       Optical Properties
              , ss_prop &
!                        Cloudy properties
              , l_cloud, i_cloud &
!                        Cloud geometry
              , n_cloud_top &
              , n_cloud_type, frac_cloud &
              , n_region, k_clr, i_region_cloud, frac_region &
              , w_free, w_cloud, cloud_overlap &
              , n_column_slv, list_column_slv &
              , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
              , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
              , n_direction, direction &
!                        Weighting factor for the band
              , weight_band(i_band), l_initial &
!                        Fluxes calculated
              , flux_direct(1, 0, map_channel(i_band)) &
              , flux_down(1, 0, map_channel(i_band)) &
              , flux_up(1, 0, map_channel(i_band)) &
!                        Radiances
              , i_direct, radiance(1, 1, 1, map_channel(i_band)) &
!                        Rate of photolysis
              , photolysis(1, 1, map_channel(i_band)) &
!                        Flags for clear-sky calculations
              , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
              , flux_direct_clear(1, 0, map_channel(i_band)) &
              , flux_down_clear(1, 0, map_channel(i_band)) &
              , flux_up_clear(1, 0, map_channel(i_band)) &
!                       Tiled Surface Fluxes
              , flux_up_tile(1, 1, map_channel(i_band)) &
              , flux_up_blue_tile(1, 1, map_channel(i_band)) &
!                       Special Surface Fluxes
              , l_blue_flux_surf, weight_blue(i_band) &
              , flux_direct_blue_surf &
              , flux_down_blue_surf, flux_up_blue_surf &
!                        Dimensions of arrays
              , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
              , nd_flux_profile, nd_radiance_profile, nd_j_profile &
              , nd_band, nd_species &
              , nd_esft_term, nd_scale_variable &
              , nd_cloud_type, nd_region, nd_overlap_coeff &
              , nd_max_order, nd_sph_coeff &
              , nd_brdf_basis_fnc, nd_brdf_trunc &
              , nd_viewing_level, nd_direction &
              , nd_source_coeff, nd_point_tile, nd_tile &
              )
!
          ELSE
            WRITE(iu_err, '(3(/a))') &
              '*** Error: An appropriate gaseous overlap' &
              , 'has not been specified, even though gaseous' &
              , 'absorption is to be included.'
          ENDIF
        ENDIF
!
!       Deallocate the single scattering propeties.
!
        DEALLOCATE(ss_prop%k_grey_tot_clr)
        DEALLOCATE(ss_prop%k_ext_scat_clr)
        DEALLOCATE(ss_prop%tau_clr)
        DEALLOCATE(ss_prop%omega_clr)
        DEALLOCATE(ss_prop%phase_fnc_clr)
        DEALLOCATE(ss_prop%forward_scatter_clr)
        DEALLOCATE(ss_prop%forward_solar_clr)
        DEALLOCATE(ss_prop%phase_fnc_solar_clr)
!
        DEALLOCATE(ss_prop%k_grey_tot)
        DEALLOCATE(ss_prop%k_ext_scat)
        DEALLOCATE(ss_prop%tau)
        DEALLOCATE(ss_prop%omega)
        DEALLOCATE(ss_prop%phase_fnc)
        DEALLOCATE(ss_prop%forward_scatter)
        DEALLOCATE(ss_prop%forward_solar)
        DEALLOCATE(ss_prop%phase_fnc_solar)
!
!
!       Make any adjustments to fluxes and radiances to convert
!       to actual values. This is done inside the loop over bands
!       to allow for division of the output fluxes between
!       separate diagnostic bands.
        IF (isolir == IP_infra_red) THEN
          CALL adjust_ir_radiance(n_profile, n_layer, n_viewing_level &
            , n_direction, i_angular_integration, i_sph_mode &
            , planck_flux_band, planck_radiance_band &
            , flux_down(1, 0, map_channel(i_band)) &
            , flux_up(1, 0, map_channel(i_band)) &
            , radiance(1, 1, 1, map_channel(i_band)) &
            , l_clear &
            , flux_down_clear(1, 0, map_channel(i_band)) &
            , flux_up_clear(1, 0, map_channel(i_band)) &
            , nd_2sg_profile, nd_flux_profile, nd_radiance_profile &
            , nd_layer, nd_direction, nd_viewing_level &
            )
        ENDIF
!
!
      ENDDO
!
!
      RETURN
      END SUBROUTINE RADIANCE_CALC
!+ Subroutine to convert differential IR radiances to actual ones.
!
! Purpose:
!   This subroutine receives differntial IR radiances or fluxes
!   and returns actual values.
!
! Method:
!   Striaghtforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE adjust_ir_radiance(n_profile, n_layer, n_viewing_level &
        , n_direction, i_angular_integration, i_sph_mode &
        , planck_flux, planck_radiance &
        , flux_down, flux_up, radiance &
        , l_clear, flux_down_clear, flux_up_clear &
        , nd_2sg_profile, nd_flux_profile, nd_radiance_profile &
        , nd_layer, nd_direction, nd_viewing_level &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
      USE angular_integration_pcf
      USE spectral_region_pcf
      USE sph_mode_pcf
!
!
      IMPLICIT NONE
!
!
!     Dummy array sizes
      INTEGER, Intent(IN) :: &
          nd_2sg_profile &
!           Size allocated for profiles of fluxes
        , nd_flux_profile &
!           Size allocated for profiles of output fluxes
        , nd_radiance_profile &
!           Size allocated for atmospheric profiles for
!           quantities used in calculations of radiances
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_viewing_level &
!           Size allocated for levels for radiances
        , nd_direction
!           Size allocated for directions
!
!
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric profiles
        , n_layer &
!           Number of atmospheric layers
        , n_direction &
!           Number of directions
        , n_viewing_level
!           Number of levels at which to calculate radiances
      INTEGER, Intent(IN) :: &
          i_angular_integration &
!           Angular integration scheme
        , i_sph_mode
!           Mode in which the spherical solver is used
      REAL  (RealK), Intent(IN) :: &
          planck_flux(nd_flux_profile, 0: nd_layer) &
!           Planckian fluxes
        , planck_radiance(nd_radiance_profile, nd_viewing_level)
!           Planckian radiances
      LOGICAL, Intent(IN) :: &
          l_clear
!           Calculate clear-sky fluxes
!
      REAL  (RealK), Intent(INOUT) :: &
          flux_down(nd_flux_profile, 0: nd_layer) &
!           Downward fluxes
        , flux_up(nd_flux_profile, 0: nd_layer) &
!           Upward fluxes
        , radiance(nd_radiance_profile, nd_viewing_level, nd_direction) &
!           Radiances in specified directions
        , flux_down_clear(nd_flux_profile, 0: nd_layer) &
!           Clear downward flux
        , flux_up_clear(nd_flux_profile, 0: nd_layer)
!           Clear upward flux
!
!
!     Local arguments
      INTEGER &
          i &
!           Loop variable
        , id &
!           Loop variable
        , l
!           Loop variable
!
!
!
      IF ( (i_angular_integration == IP_two_stream).OR. &
           (i_angular_integration == IP_ir_gauss) ) THEN
!
        DO i=0, nd_layer
          DO l=1, nd_flux_profile
            flux_up(l, i)=flux_up(l, i)+planck_flux(l, i)
            flux_down(l, i)=flux_down(l, i)+planck_flux(l, i)
          ENDDO
        ENDDO
        IF (l_clear) THEN
          DO i=0, nd_layer
            DO l=1, nd_flux_profile
              flux_up_clear(l,i)=flux_up_clear(l,i)+planck_flux(l,i)
              flux_down_clear(l,i)=flux_down_clear(l,i)+planck_flux(l,i)
            ENDDO
          ENDDO
        ENDIF
!
      ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
!       Planckian radiances are always used with spherical harmonics,
!       even when calculating fluxes. The number of levels should
!       be set appropriately above.
        IF (i_sph_mode == IP_sph_mode_flux) THEN
          DO i=0, nd_layer
            DO l=1, nd_flux_profile
              flux_up(l, i)=flux_up(l, i)+pi*planck_radiance(l, i+1)
              flux_down(l, i)=flux_down(l, i) &
                +pi*planck_radiance(l, i+1)
            ENDDO
          ENDDO
!hmjb - fix clear-sky longwave
        IF (l_clear) THEN
          DO i=0, nd_layer
            DO l=1, nd_flux_profile
              flux_up_clear(l, i)=flux_up_clear(l, i) &
                +pi*planck_radiance(l, i+1)
              flux_down_clear(l, i)=flux_down_clear(l, i) &
                +pi*planck_radiance(l, i+1)
            ENDDO
          ENDDO
       ENDIF
!hmjb
        ELSE IF (i_sph_mode == IP_sph_mode_rad) THEN
          DO id=1, nd_direction
            DO i=1, nd_viewing_level
              DO l=1, nd_radiance_profile
                radiance(l, i, id)=radiance(l, i, id) &
                  +planck_radiance(l, i)
              ENDDO
            ENDDO
          ENDDO
        ENDIF
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE ADJUST_IR_RADIANCE
!+ Subroutine to aggregate clouds into regions.
!
! Method:
!        The clouds in a layer are combined in groups to form regions
!       which will be considered as bulk entities in the solution of the
!       equation of transfer. The extents of these regions are also
!       determined.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE aggregate_cloud(ierr &
         , n_profile, n_layer, n_cloud_top &
         , i_cloud, i_cloud_representation, n_cloud_type &
         , frac_cloud &
         , i_region_cloud, frac_region &
         , nd_profile, nd_layer, nd_cloud_type, nd_region &
         , id_ct &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE error_pcf
      USE cloud_representation_pcf
      USE cloud_type_pcf
      USE cloud_region_pcf
      USE cloud_scheme_pcf
!
!
      IMPLICIT NONE
!
!
!     Dummy array sizes
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , nd_cloud_type &
!           Maximum number of types of cloud
        , nd_region &
!           Maximum number of cloudy regions
        , id_ct
!           Topmost declared cloudy layer
!
!     Inclusion of header files.
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Topmost cloudy layer
      INTEGER, Intent(IN) :: &
          i_cloud &
!           Cloud scheme used
        , i_cloud_representation &
!           Representation of clouds used
        , n_cloud_type
!           Number of types of cloud
!
      REAL  (RealK), Intent(IN) :: &
          frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!           Fractions of each type of cloud
!
      INTEGER, Intent(OUT) :: &
          i_region_cloud(nd_cloud_type)
!           Regions in which particular types of cloud fall
      REAL  (RealK), Intent(OUT) :: &
          frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fractions of total cloud occupied by each region
!
!
!     Local variables
      INTEGER &
          i &
!           Loop variable
        , l &
!           Loop variable
        , k
!           Loop variable
!
!
!
      IF ( (i_cloud == IP_cloud_triple).OR. &
           (i_cloud == IP_cloud_part_corr_cnv) ) THEN
!
        IF (i_cloud_representation == IP_cloud_csiw) THEN
!
          DO k=1, n_cloud_type
            IF (k == IP_cloud_type_sw) THEN
              i_region_cloud(k)=IP_region_strat
            ELSE IF (k == IP_cloud_type_si) THEN
              i_region_cloud(k)=IP_region_strat
            ELSE IF (k == IP_cloud_type_cw) THEN
              i_region_cloud(k)=IP_region_conv
            ELSE IF (k == IP_cloud_type_ci) THEN
              i_region_cloud(k)=IP_region_conv
            ENDIF
          ENDDO
!
!hmjb The way this is implemented the user MUST always set frac_cloud
!  in the order defined in cloud_type_pcf, and not following what
!  he (the user) choose for the type_condensed
!
          DO i=1, nd_layer
            DO l=1, nd_profile
              frac_region(l, i, IP_region_strat) &
                =frac_cloud(l, i, IP_cloud_type_sw) &
                +frac_cloud(l, i, IP_cloud_type_si)
              frac_region(l, i, IP_region_conv) &
                =frac_cloud(l, i, IP_cloud_type_cw) &
                +frac_cloud(l, i, IP_cloud_type_ci)
            ENDDO
          ENDDO
!
        ELSE IF (i_cloud_representation == IP_cloud_conv_strat) THEN
!
          DO k=1, n_cloud_type
            IF (k == IP_cloud_type_strat) THEN
              i_region_cloud(k)=IP_region_strat
            ELSE IF (k == IP_cloud_type_conv) THEN
              i_region_cloud(k)=IP_region_conv
            ENDIF
          ENDDO
!
          DO i=1, nd_layer
            DO l=1, nd_profile
              frac_region(l, i, IP_region_strat) &
                =frac_cloud(l, i, IP_cloud_type_strat)
              frac_region(l, i, IP_region_conv) &
                =frac_cloud(l, i, IP_cloud_type_conv)
             ENDDO
          ENDDO
!
!
        ELSE
          WRITE(iu_err, '(/a, /a)') &
            '*** Error: This representation of clouds is not ' &
            //'compatible with separate ' &
            , 'convective and stratiform and overlap.'
          ierr=i_err_fatal
          RETURN
        ENDIF
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE AGGREGATE_CLOUD
!+ Subroutine to increment a radiances or fluxes.
!
! Method:
!        The arrays holding the summed fluxes or radiances are
!        incremented by a weighted sum of the variables suffixed
!        with _INCR. Arguments specify which arrays are to be
!       incremented.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE augment_radiance(n_profile, n_layer &
        , i_angular_integration, i_sph_mode &
        , n_viewing_level, n_direction &
        , isolir, l_clear &
        , l_initial, weight_incr &
        , l_blue_flux_surf, weight_blue &
!                        Actual radiances
        , flux_direct, flux_down, flux_up &
        , flux_direct_blue_surf &
        , flux_down_blue_surf, flux_up_blue_surf &
        , i_direct, radiance, photolysis &
        , flux_direct_clear, flux_down_clear, flux_up_clear &
!                        Increments to radiances
        , flux_direct_incr, flux_total_incr &
        , i_direct_incr, radiance_incr, photolysis_incr &
        , flux_direct_incr_clear, flux_total_incr_clear &
!                        Dimensions
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_layer, nd_viewing_level, nd_direction &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE angular_integration_pcf
      USE sph_mode_pcf
      USE sph_algorithm_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_flux_profile &
!           Size allocated for points where fluxes are calculated
        , nd_radiance_profile &
!           Size allocated for points where radiances are calculated
        , nd_j_profile &
!           Size allocated for points where photolysis is calculated
        , nd_layer &
!           Size allocated for layers
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_direction
!           Size allocated for viewing directions
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_viewing_level &
!           Number of levels where the radiance is calculated
        , n_direction
!           Number of viewing directions
      INTEGER, Intent(IN) :: &
          isolir &
!           Spectral region
        , i_sph_mode &
!           Mode in which spherical harmonics are used
        , i_angular_integration
!           Treatment of angular integration
      LOGICAL, Intent(IN) :: &
          l_clear &
!           Clear fluxes calculated
        , l_initial
!           Logical to perform initialization instead of incrementing
!
      REAL  (RealK), Intent(IN) :: &
          weight_incr
!           Weight to apply to incrementing fluxes
!
!                        Increments to Fluxes
      REAL  (RealK), Intent(IN) :: &
          flux_direct_incr(nd_flux_profile, 0: nd_layer) &
!           Increment to direct flux
        , flux_total_incr(nd_flux_profile, 2*nd_layer+2) &
!           Increment to total flux
        , flux_direct_incr_clear(nd_flux_profile, 0: nd_layer) &
!           Increment to clear direct flux
        , flux_total_incr_clear(nd_flux_profile, 2*nd_layer+2)
!           Increment to clear total flux
!                        Increments to Radiances
      REAL  (RealK), Intent(IN) :: &
          i_direct_incr(nd_radiance_profile, 0: nd_layer) &
!           Increments to the solar irradiance
        , radiance_incr(nd_radiance_profile, nd_viewing_level &
            , nd_direction)
!           Increments to the radiance
!                        Increments to Rates of photolysis
      REAL  (RealK), Intent(IN) :: &
          photolysis_incr(nd_j_profile, nd_viewing_level)
!           Increments to the rates of photolysis
!
!                        Total Fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct flux
        , flux_down(nd_flux_profile, 0: nd_layer) &
!           Total downward flux
        , flux_up(nd_flux_profile, 0: nd_layer) &
!           Upward flux
        , flux_direct_clear(nd_flux_profile, 0: nd_layer) &
!           Clear direct flux
        , flux_down_clear(nd_flux_profile, 0: nd_layer) &
!           Clear total downward flux
        , flux_up_clear(nd_flux_profile, 0: nd_layer)
!           Clear upward flux
!                        Total Radiances
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_radiance_profile, 0: nd_layer) &
!           Solar irradiance
        , radiance(nd_radiance_profile, nd_viewing_level &
            , nd_direction)
!           Radiance
!                       Rates of photolysis
      REAL  (RealK), Intent(INOUT) :: &
          photolysis(nd_j_profile, nd_viewing_level)
!           Rates of photolysis
!
!                        Special Diagnostics:
      LOGICAL, Intent(IN) :: &
          l_blue_flux_surf
!           Flag to calculate blue fluxes at the surface
      REAL  (RealK), Intent(IN) :: &
          weight_blue
!           Weights for blue fluxes in this band
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_blue_surf(nd_flux_profile) &
!           Direct blue flux at the surface
        , flux_down_blue_surf(nd_flux_profile) &
!           Total downward blue flux at the surface
        , flux_up_blue_surf(nd_flux_profile)
!           Upward blue flux at the surface
!
!
!
!     Local arguments.
      INTEGER &
          i &
!           Loop variable
        , l &
!           Loop variable
        , k
!           Loop variable
!
!
!
      IF (.NOT.l_initial) THEN
!
!       Most commonly, this routine will be called to increment
!       rather than to initialize fluxes.
!
        IF ( (i_angular_integration == IP_two_stream).OR. &
             (i_angular_integration == IP_ir_gauss).OR. &
           ( (i_angular_integration == IP_spherical_harmonic).AND. &
             (i_sph_mode == IP_sph_mode_flux) ) ) THEN
!
!         Increment the actual fluxes.
          IF (isolir == IP_solar) THEN
            DO i=0, nd_layer
              DO l=1, nd_flux_profile
                flux_direct(l, i)=flux_direct(l, i) &
                  +weight_incr*flux_direct_incr(l, i)
              ENDDO
            ENDDO
            IF (l_blue_flux_surf) THEN
              DO l=1, nd_flux_profile
                flux_up_blue_surf(l)=flux_up_blue_surf(l) &
                  +weight_blue*flux_total_incr(l, 2*n_layer+1)
                flux_down_blue_surf(l)=flux_down_blue_surf(l) &
                  +weight_blue*flux_total_incr(l, 2*n_layer+2)
              ENDDO
              IF (isolir == IP_solar) THEN
                DO l=1, nd_flux_profile
                  flux_direct_blue_surf(l)=flux_direct_blue_surf(l) &
                    +weight_blue*flux_direct_incr(l, n_layer)
                ENDDO
              ENDIF
            ENDIF
          ENDIF
          DO i=0, nd_layer
            DO l=1, nd_flux_profile
              flux_up(l, i)=flux_up(l, i) &
                +weight_incr*flux_total_incr(l, 2*i+1)
              flux_down(l, i)=flux_down(l, i) &
                +weight_incr*flux_total_incr(l, 2*i+2)
            ENDDO
          ENDDO
!
          IF (l_clear) THEN
            IF (isolir == IP_solar) THEN
              DO i=0, nd_layer
                DO l=1, nd_flux_profile
                  flux_direct_clear(l, i)=flux_direct_clear(l, i) &
                    +weight_incr*flux_direct_incr_clear(l, i)
                ENDDO
              ENDDO
            ENDIF
            DO i=0, nd_layer
              DO l=1, nd_flux_profile
                flux_up_clear(l, i)=flux_up_clear(l, i) &
                  +weight_incr*flux_total_incr_clear(l, 2*i+1)
                flux_down_clear(l, i)=flux_down_clear(l, i) &
                  +weight_incr*flux_total_incr_clear(l, 2*i+2)
              ENDDO
            ENDDO
          ENDIF
!
        ELSE IF ( (i_angular_integration == IP_spherical_harmonic).AND. &
                  (i_sph_mode == IP_sph_mode_rad) ) THEN
!
          DO k=1, nd_direction
            DO i=1, nd_viewing_level
              DO l=1, nd_radiance_profile
                radiance(l, i, k)=radiance(l, i, k) &
                  +weight_incr*radiance_incr(l, i, k)
              ENDDO
            ENDDO
          ENDDO
!
          IF (isolir == IP_solar) THEN
            DO i=0, nd_layer
              DO l=1, nd_flux_profile
                i_direct(l, i)=i_direct(l, i) &
                  +weight_incr*i_direct_incr(l, i)
              ENDDO
            ENDDO
          ENDIF
!
        ELSE IF ( (i_angular_integration == IP_spherical_harmonic).AND. &
                  (i_sph_mode == IP_sph_mode_j) ) THEN
!
          DO i=1, nd_viewing_level
            DO l=1, nd_j_profile
              photolysis(l, i)=photolysis(l, i) &
                +weight_incr*photolysis_incr(l, i)
            ENDDO
          ENDDO
!
        ENDIF
!
      ELSE
!
!       Initialization of the radiance field takes place here.
!
        IF ( (i_angular_integration == IP_two_stream).OR. &
             (i_angular_integration == IP_ir_gauss).OR. &
           ( (i_angular_integration == IP_spherical_harmonic).AND. &
              (i_sph_mode == IP_sph_mode_flux) ) ) THEN
!
!         Increment the actual fluxes.
          IF (isolir == IP_solar) THEN
            DO i=0, nd_layer
              DO l=1, nd_flux_profile
                flux_direct(l, i)=weight_incr*flux_direct_incr(l, i)
              ENDDO
            ENDDO
            IF (l_blue_flux_surf) THEN
              DO l=1, nd_flux_profile
                flux_up_blue_surf(l) &
                  =weight_blue*flux_total_incr(l, 2*n_layer+1)
                flux_down_blue_surf(l) &
                  =weight_blue*flux_total_incr(l, 2*n_layer+2)
              ENDDO
              IF (isolir == IP_solar) THEN
                DO l=1, nd_flux_profile
                  flux_direct_blue_surf(l) &
                    =weight_blue*flux_direct_incr(l, n_layer)
                ENDDO
              ENDIF
            ENDIF
          ENDIF
          DO i=0, nd_layer
            DO l=1, nd_flux_profile
              flux_up(l, i)=weight_incr*flux_total_incr(l, 2*i+1)
              flux_down(l, i)=weight_incr*flux_total_incr(l, 2*i+2)
            ENDDO
          ENDDO
!
          IF (l_clear) THEN
            IF (isolir == IP_solar) THEN
              DO i=0, nd_layer
                DO l=1, nd_flux_profile
                  flux_direct_clear(l, i) &
                    =weight_incr*flux_direct_incr_clear(l, i)
                ENDDO
              ENDDO
            ENDIF
            DO i=0, nd_layer
              DO l=1, nd_flux_profile
                flux_up_clear(l, i) &
                  =weight_incr*flux_total_incr_clear(l, 2*i+1)
                flux_down_clear(l, i) &
                  =weight_incr*flux_total_incr_clear(l, 2*i+2)
              ENDDO
            ENDDO
          ENDIF
!
        ELSE IF ( (i_angular_integration == IP_spherical_harmonic).AND. &
                  (i_sph_mode == IP_sph_mode_rad) ) THEN
!
!         Increment the radiances on levels where they are calculated.
          DO k=1, nd_direction
            DO i=1, nd_viewing_level
              DO l=1, nd_radiance_profile
                radiance(l, i, k)=weight_incr*radiance_incr(l, i, k)
              ENDDO
            ENDDO
          ENDDO
!
          IF (isolir == IP_solar) THEN
            DO i=0, nd_layer
              DO l=1, nd_radiance_profile
                i_direct(l, i)=weight_incr*i_direct_incr(l, i)
              ENDDO
            ENDDO
          ENDIF
!
        ELSE IF ( (i_angular_integration == IP_spherical_harmonic).AND. &
                  (i_sph_mode == IP_sph_mode_j) ) THEN
!
          DO i=1, nd_viewing_level
            DO l=1, nd_j_profile
              photolysis(l, i)=weight_incr*photolysis_incr(l, i)
            ENDDO
          ENDDO
!
        ENDIF
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE AUGMENT_RADIANCE
!+ Subroutine to increment upward fluxes on a tiled surface.
!
! Method:
!        The arrays holding the local cumulative fluxes or radiances
!       on each tile are incremented by the variables suffixed
!        with _INCR, multiplied by appropriate weights. The routine
!       can be called to initialize fluxes.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE augment_tiled_radiance(ierr &
        , n_point_tile, n_tile, list_tile &
        , i_angular_integration, isolir, l_initial &
        , weight_incr, l_blue_flux_surf, weight_blue_incr &
!                        Surface characteristics
        , rho_alb &
!                        Actual radiances
        , flux_up_tile, flux_up_blue_tile &
!                        Increments to radiances
        , flux_direct_incr, flux_down_incr &
        , planck_flux_tile, planck_flux_air &
!                        Dimensions
        , nd_flux_profile, nd_point_tile, nd_tile &
        , nd_brdf_basis_fnc &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE angular_integration_pcf
      USE error_pcf
      USE def_std_io_icf
      USE surface_spec_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_flux_profile &
!           Size allocated for points where fluxes are calculated
        , nd_point_tile &
!           Size allocated for points where the surface is tiled
        , nd_tile &
!           Size allocated for surface tiles
        , nd_brdf_basis_fnc
!           Size allocated for BRDF basis functions
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
      INTEGER, Intent(IN) :: &
          n_point_tile &
!           Number of points where the surface is tiled
        , n_tile &
!           Number of tiles used
        , list_tile(nd_point_tile)
!           List of tiled points
      INTEGER, Intent(IN) :: &
          isolir &
!           Spectral region
        , i_angular_integration
!           Treatment of angular integration
      LOGICAL, Intent(INOUT) :: &
          l_initial
!           Flag to call the routine to initialize the outputs
      LOGICAL, Intent(IN) :: &
          l_blue_flux_surf
!           Flag to increment blue surface fluxes
      REAL  (RealK), Intent(IN) :: &
          weight_incr &
!           Weight to apply to increments
        , weight_blue_incr
!           Weight to apply to increments to blue fluxes
!
!                        Surface Characteristics
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_point_tile, nd_brdf_basis_fnc, nd_tile)
!           Weighting functions for BRDFs
!
!                        Increments to Fluxes
      REAL  (RealK), Intent(IN) :: &
          flux_direct_incr(nd_flux_profile) &
!           Increment to mean direct flux
        , flux_down_incr(nd_flux_profile)
!           Increment to total downward flux
!
!                        Planckian Fluxes
      REAL  (RealK), Intent(IN) :: &
          planck_flux_tile(nd_point_tile, nd_tile) &
!           Local Planckian flux emitted from each tile
        , planck_flux_air(nd_flux_profile)
!           Hemispheric Planckian flux at the temperature of the air
!
!                        Total Fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_up_tile(nd_point_tile, nd_tile) &
!           Local upward flux on each tile (not weighted by the
!           fractional coverage of the tile)
        , flux_up_blue_tile(nd_point_tile, nd_tile)
!           Local upward blue flux on each tile (not weighted by the
!           fractional coverage of the tile)
!
!
!     Local arguments.
      INTEGER &
          l &
!           Loop variable
        , ll &
!           Loop variable
        , k
!           Loop variable
!
!
!
      IF (.NOT.l_initial) THEN
!
!       Most commonly, this routine will be called to increment
!       rather than to initialize fluxes.
!
        IF ( (i_angular_integration == IP_two_stream).OR. &
             (i_angular_integration == IP_ir_gauss) ) THEN
!
!         Increment the actual fluxes.
          IF (isolir == IP_solar) THEN
!
            DO k=1, n_tile
              DO ll=1, n_point_tile
                l=list_tile(ll)
                flux_up_tile(ll, k)=flux_up_tile(ll, k) &
                  +weight_incr &
                  *(rho_alb(ll, IP_surf_alb_diff, k)*flux_down_incr(l) &
                  +(rho_alb(ll, IP_surf_alb_dir, k) &
                  -rho_alb(ll, IP_surf_alb_diff, k)) &
                  *flux_direct_incr(l))
              ENDDO
            ENDDO
!
            IF (l_blue_flux_surf) THEN
              DO k=1, n_tile
                DO ll=1, n_point_tile
                  l=list_tile(ll)
                  flux_up_blue_tile(ll, k)=flux_up_blue_tile(ll, k) &
                    +weight_blue_incr &
                    *(rho_alb(ll, IP_surf_alb_diff, k) &
                    *flux_down_incr(l) &
                    +(rho_alb(ll, IP_surf_alb_dir, k) &
                    -rho_alb(ll, IP_surf_alb_diff, k)) &
                    *flux_direct_incr(l))
                ENDDO
              ENDDO
            ENDIF
!
          ELSE IF (isolir == IP_infra_red) THEN
!
            DO k=1, n_tile
              DO ll=1, n_point_tile
                l=list_tile(ll)
                flux_up_tile(ll, k)=flux_up_tile(ll, k) &
                  +weight_incr*(planck_flux_tile(ll, k) &
                  +rho_alb(ll, IP_surf_alb_diff, k) &
                  *(flux_down_incr(l) &
                  +planck_flux_air(l)-planck_flux_tile(ll, k)))
              ENDDO
            ENDDO
          ENDIF
!
        ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
          WRITE(iu_err, '(/a)') &
            '*** Error: Tiled surfaces have not yet been ' &
            , 'implemented with the spherical harmonic solver.'
          ierr=i_err_fatal
          RETURN
!
        ENDIF
!
      ELSE
!
!       Initialization of the radiance field takes place here.
!
        IF ( (i_angular_integration == IP_two_stream).OR. &
             (i_angular_integration == IP_ir_gauss) ) THEN
!
!         Initialize the actual fluxes.
          IF (isolir == IP_solar) THEN
            DO k=1, n_tile
              DO ll=1, n_point_tile
                l=list_tile(ll)
                flux_up_tile(ll, k)=weight_incr &
                  *(rho_alb(ll, IP_surf_alb_diff, k)*flux_down_incr(l) &
                  +(rho_alb(ll, IP_surf_alb_dir, k) &
                  -rho_alb(ll, IP_surf_alb_diff, k)) &
                  *flux_direct_incr(l))
              ENDDO
            ENDDO
!
            IF (l_blue_flux_surf) THEN
              DO k=1, n_tile
                DO ll=1, n_point_tile
                  l=list_tile(ll)
                  flux_up_blue_tile(ll, k) &
                    =weight_blue_incr*(rho_alb(ll, IP_surf_alb_diff, k) &
                    *flux_down_incr(l) &
                    +(rho_alb(ll, IP_surf_alb_dir, k) &
                    -rho_alb(ll, IP_surf_alb_diff, k)) &
                    *flux_direct_incr(l))
                ENDDO
              ENDDO
            ENDIF
!
          ELSE IF (isolir == IP_infra_red) THEN
!
            DO k=1, n_tile
              DO ll=1, n_point_tile
                l=list_tile(ll)
                flux_up_tile(ll, k) &
                  =weight_incr*(planck_flux_tile(ll, k) &
                  +rho_alb(ll, IP_surf_alb_diff, k) &
                  *(flux_down_incr(l) &
                  +planck_flux_air(l)-planck_flux_tile(ll, k)))
              ENDDO
            ENDDO
!
          ENDIF
!
        ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
          WRITE(iu_err, '(/a)') &
            '*** Error: Tiled surfaces have not yet been ' &
            , 'implemented with the spherical harmonic solver.'
          ierr=i_err_fatal
          RETURN
!
        ENDIF
!
!       Now reset the initialization flag as the arrays have been set.
        l_initial=.false.
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE AUGMENT_TILED_RADIANCE
!+ Subroutine to solve a set of banded matrix equations.
!
! Method:
!        A set of bands matrix equations is solved using the
!        standard method of Gaussian elimination. Diagonals are
!       numbered downward (i.e. upper diagonals first).
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE band_solver(n_matrix, n_equation &
        , iu, il &
        , a, b &
        , x &
        , rho &
        , nd_matrix, nd_diagonal, nd_equation &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_matrix &
!           Size alloacted for matrices
        , nd_diagonal &
!           Size allocated for diagonals
        , nd_equation
!           Size allocated for equations
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          n_matrix &
!           Number of matrices
        , n_equation &
!           Number of equations
        , iu &
!           Number of superdiagonals
        , il
!           Number of subdiagonals
      REAL  (RealK), Intent(INOUT) :: &
          a(nd_matrix, nd_diagonal, nd_equation) &
!           Matrices of coefficients
        , b(nd_matrix, nd_equation)
!           Righthand sides
      REAL  (RealK), Intent(OUT) :: &
           x(nd_matrix, nd_equation)
!           Solution vector
      REAL  (RealK) ::         & !, intent(work)
           rho(nd_matrix)
!           Temporary array
!
!     Local variables
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l &
!           Loop variable
        , iu1
!           Local scalar
!
!
      iu1=iu+1
!     Eliminative phase.
      DO i=n_equation, 2, -1
        DO j=1, min(iu, i-1)
          DO l=1, n_matrix
            rho(l)=a(l, iu1-j, i-j)/a(l, iu1, i)
            b(l, i-j)=b(l, i-j)-rho(l)*b(l, i)
          ENDDO
          DO k=1, min(il, i-1)
            DO l=1, n_matrix
              a(l, iu1+k-j, i-j)=a(l, iu1+k-j, i-j) &
                -rho(l)*a(l, iu1+k, i)
            ENDDO
          ENDDO
        ENDDO
      ENDDO
!
!     Solution and back-substitution:
!
      IF ( (iu == 2).AND.(il == 2) ) THEN
!       A special version is used for the pentadiagonal case to allow
!       us to chain operations together for efficiency on the CRAY
!       vector machines, as this particular case arises quite often.
!
!       First equation:
        DO l=1, n_matrix
          x(l, 1)=b(l, 1)/a(l, 3, 1)
        ENDDO
!       Second equation:
        DO l=1, n_matrix
          x(l, 2)=(b(l, 2)-a(l, 4, 2)*x(l, 1))/a(l, 3, 2)
        ENDDO
!       Remaining equations:
        DO i=3, n_equation
          DO l=1, n_matrix
            x(l, i)=(b(l, i)-a(l, 4, i)*x(l, i-1) &
              -a(l, 5, i)*x(l, i-2))/a(l, 3, i)
          ENDDO
        ENDDO
      ELSE
!
!       General case:
        DO i=1, n_equation
          DO l=1, n_matrix
               x(l, i)=b(l, i)
          ENDDO
          DO k=1, min(il, i-1)
            DO l=1, n_matrix
              x(l, i)=x(l, i)-a(l, iu1+k, i)*x(l, i-k)
            ENDDO
          ENDDO
          DO l=1, n_matrix
            x(l, i)=x(l, i)/a(l, iu1, i)
          ENDDO
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE BAND_SOLVER
!+ Subroutine to build up the matrix for radiances.
!
! Purpose:
!   This routine assembles the stepped matrix to solve the equation
!   of transfer for a specific value of the azimuthal quantum
!   number.
!
! Method:
!
!   Labelling of variables and equations:
!     The variables are u_{ik}^{-|+} where i runs over all the layers
!   1,...,N_LAYER and k runs over positive eigenvalues of the reduced
!   eigensystem 1,...,N_RED_EIGENSYSTEM: there are thus 2n_e variables
!   describing the radiance in each layer, so the number of a variable
!   is
!      IV=2n_e(i-1)+k+n_e(1+|-1)/2
!   (Note that u_{ik}^- preceeds u_{ik}^+ by N_RED_EIGENSYSTEM).
!   At the top of the atmosphere (L''+1-m)/2 conditions are applied by
!   Marshak''s conditions, where l'=m+1,...,L' in steps of 2, so for
!   this boundary
!      IE=(l''+1-m)/2
!   At the i''th interior boundary a condition of continuity is applied
!   to I_{lm}, where l=m,...,L''. To match the numbering of the equations
!   at the boundary values of l=m, m+2,...,L''-1 in steps of 2 are taken
!   first followed by those with l=m+1,...,L'', so the number of the
!   equation is
!      IE=n_e(2i-1)+(l-m)/2+1,           l=m, m+2,...,L''-1
!      IE=n_e(2i-1)+(l+1-m)/2+n_e,       l=m+1,...,L'',
!   allowing for n_e conditions at the top of the model and 2n_e
!   conditions at higher interfaces. At the bottom of the atmosphere
!   Marshak''s condition is imposed using the harmonics l'=m+1,...,L'
!   in steps of 2, so the numbering of equations is
!      IE=n_e(2N_LAYER-1)+(l''+1-m)/2
!     Each of these equations couples together u_{ik}^{+|-} in the
!   layers above and below the interface. Hence, each equation
!   IE=(2i-1)n_e+1,...,(2i+1)n_e involves the variables IV=(2i-1)n_e+1,
!   ...,(2i+1)n_e, producing a stepped diagonal matrix which can be
!   encoded in an array of 4n_e columns with IE indexing the rows.
!   3n_e-1 sub-diagonals. The mapping is:
!     (IE, IV) --> (IE, IV-2*N_RED_EIGENSYSTEM*(I-1))
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE build_sph_matrix(i_sph_algorithm, euler_factor &
!                        Basic sizes
        , n_profile, n_layer, ls_trunc, ms, n_red_eigensystem &
!                        Numerical arrays of spherical terms
        , cg_coeff, kappa, up_lm &
!                        Solar variables
        , isolir, i_direct, mu_0, uplm_sol, azim_factor &
!                        Infra-red variables
        , diff_planck, l_ir_source_quad, diff_planck_2 &
!                        Diffuse incident field
        , flux_down_inc &
!                        Optical properies
        , tau, omega, phase_fnc &
!                        Surface Fields
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi, cgk &
        , d_planck_flux_surface &
!                        Levels where radiances are calculated
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
        , n_direction, mu_v &
!                        Output variables
        , a, b, c_ylm, weight_u, radiance &
!                        Dimensions
        , nd_profile, nd_radiance_profile, nd_layer &
        , nd_viewing_level, nd_direction &
        , nd_max_order, nd_brdf_basis_fnc, nd_brdf_trunc &
        , nd_red_eigensystem, nd_sph_equation, nd_sph_diagonal &
        , nd_sph_cf_weight, nd_sph_u_range &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE sph_algorithm_pcf
      USE spectral_region_pcf
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_radiance_profile &
!           Size allocated for atmospheric profiles where radiances
!           are calculated
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_viewing_level &
!           Allocated size for levels where radiances are calculated
        , nd_direction &
!           Allocated size for viewing directions
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_brdf_basis_fnc &
!           Size allocated for BRDF basis functions
        , nd_brdf_trunc &
!           Size allocated for orders in BRDFs
        , nd_red_eigensystem &
!           Size allocated for the reduced eigensystem
        , nd_sph_equation &
!           Size allocated for spherical harmonic equations
        , nd_sph_diagonal &
!           Size allocated for diagonals in matrix for harmonics
        , nd_sph_cf_weight &
!           Size allocated for enetities to be incremented by the
!           complementary function
        , nd_sph_u_range
!           Range of values of u^+|- contributing on any viewing
!           level
!
!
!     Dummy arguments
!     Atmospheric structrure:
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric layers
        , n_layer
!           Number of atmospheric layers
!
!     Spherical harmonic structure:
      INTEGER, Intent(IN) :: &
          i_sph_algorithm &
!           Algorithm for the spherical harmonic solution
        , ls_trunc &
!           The truncating order of the system of equations
        , ms &
!           Azimuthal order
        , n_red_eigensystem
!           Size of the reduced eigensystem
      REAL  (RealK), Intent(IN) :: &
          euler_factor
!           Factor applied to the last term of an alternating series
!
      INTEGER, Intent(IN) :: &
          isolir
!           Flag for spectral region
!
!     Optical properties:
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, nd_layer) &
!           Optical depths of the layers
        , omega(nd_profile, nd_layer) &
!           Albedos of single scattering of the layers
        , phase_fnc(nd_profile, nd_layer, nd_max_order)
!           Phase functions of the layers
!
!     Solar Fields:
      REAL  (RealK), Intent(IN) :: &
          mu_0(nd_profile) &
!           Cosine of solar zenith angle
        , i_direct(nd_profile, 0: nd_layer) &
!           The direct solar radiance
        , uplm_sol(nd_profile, ls_trunc+2-ms)
!           Spherical harmonics of the solar angle
!
!     Infra-red quantities:
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic source function in the IR
      REAL  (RealK), Intent(IN) :: &
          diff_planck(nd_profile, nd_layer) &
!           Differences in the hemispheric Planckian FLUX (bottom-top)
!           across the layer
        , diff_planck_2(nd_profile, nd_layer)
!           Twice the second differences in the hemispheric Planckian
!           FLUX
      REAL  (RealK), Intent(IN) :: &
          cg_coeff(ls_trunc+1-ms) &
!           Clebsch-Gordan coefficients
        , kappa(nd_max_order/2, nd_max_order/2) &
!           Integrals of pairs of spherical harmonics over the downward
!           hemisphere
        , cgk(nd_brdf_trunc/2+1, nd_max_order) &
!           Products of the Clebsch-Gordan coefficients and the
!           hemispheric integrals
        , up_lm(nd_profile, nd_max_order+1, nd_direction) &
!           Polar parts of spherical harmonics in viewing directions
        , flux_down_inc(nd_profile)
!           Diffuse hemispherically isotropic incident flux
!
!     Surface Fields:
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of trunation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          d_planck_flux_surface(nd_profile) &
!           Differential Planckian flux from the surface
        , rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction &
!           Number of viewing directions
        , n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          mu_v(nd_profile, nd_direction) &
!           Cosines of polar viewing directions
        , azim_factor(nd_profile, nd_direction) &
!           Azimuthal factors
        , frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!
      REAL  (RealK), Intent(INOUT) :: &
          radiance(nd_radiance_profile &
            , nd_viewing_level, nd_direction)
!           Radiances to be incremented (note that at lower
!           levels this is declared withh ND_PROFILE, but this
!           is fine since those routines will be called only
!           when the two sizes are equal)
!
      REAL  (RealK), Intent(OUT) :: &
          a(nd_profile, nd_sph_equation, nd_sph_diagonal) &
!           Matrix in the LHS of the equations
        , b(nd_profile, nd_sph_equation) &
!           Vector of forcings for the matrix equation
        , weight_u(nd_profile, nd_viewing_level, nd_sph_cf_weight &
            , nd_sph_u_range)
!           Weights to be applied to the vector U containing the
!           complementary functions
!
!                        Radiances
      REAL  (RealK), Intent(INOUT) :: &
          c_ylm(nd_profile, nd_viewing_level, ls_trunc+1-ms)
!           Coefficients for radiances
!
!
!     Local variables
      INTEGER &
          ie &
!           Number of the equation
        , ivma &
!           Index for u^- in the layer above the interface
!           This and the next three variables are used in two forms:
!           with an offset in indexing the matrix A and without
!           an offset in indexing the array WEIGHT_U.
        , ivmb &
!           Index for u^- in the layer below the interface
        , ivpa &
!           Index for u^+ in the layer above the interface
        , ivpb &
!           Index for u^+ in the layer below the interface
        , i_above &
!           Index for layer above in two-dimensional arrays
        , i_below &
!           Index for layer below in two-dimensional arrays
        , i_assign_level
!           Level where a radiance is to be assigned
      INTEGER &
          ls_p &
!           Primed polar order
        , ls &
!           Polar order
        , lsr_p &
!           Reduced primed polar order (LSR_P is MS-1 less than
!           LS_P to facilitate addressing of arrays which do not
!           hold redundant space for m>l'')
        , lsr &
!           Reduced polar order
        , ls_d &
!           Dummy polar order
        , lsr_d &
!           Reduced dummy polar order
        , ls_dd &
!           Dummy polar order
        , lsr_dd &
!           Reduced dummy polar order
        , i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l
!           Loop variable
      LOGICAL &
          l_assign
!           Controlling logical for assigning levels
      REAL  (RealK) :: &
          ss(nd_profile, 0: nd_max_order) &
!           S-coefficients for the current layer
        , ssrt(nd_profile, 0: nd_max_order)
!           Square roots of S-coefficients
      REAL  (RealK) :: &
          mu(nd_profile, nd_red_eigensystem, 2) &
!           Eigenvaluse of the reduced system
        , eig_vec(nd_profile, 2*nd_red_eigensystem &
            , nd_red_eigensystem, 2) &
!           Eigenvectors of the full systems for positive eigenvalues
!           (these are scaled by the s-coefficients in the routine
!           EIG_SYS)
        , theta(nd_profile, nd_red_eigensystem, 2) &
!           Array of exponentials of optical depths along slant paths
        , source_top(nd_profile, ls_trunc+1-ms, 2) &
!           Source function at the top of the layer
        , source_bottom(nd_profile, ls_trunc+1-ms, 2)
!           Source function at the bottom of the layer
      REAL  (RealK) :: &
          surface_term(nd_profile, ls_trunc+1-ms) &
!           Surface terms involving BRDFs
        , b_factor(nd_profile) &
!           Contribution to the RHS of the equations
        , ksi &
!           Expression involving the BRDF
        , phi &
!           Expression involving the BRDF
        , phi_d &
!           Expression involving the BRDF
        , lambda &
!           Expression involving the BRDF
        , lambda_d
!           Expression involving the BRDF
      REAL  (RealK) :: &
          z_sol(nd_profile, ls_trunc+1-ms)
!           Coefficient of the solar source function at the top of
!           the layer
      REAL  (RealK) :: &
          q_0(nd_profile) &
!           Term for thermal particular integral
        , q_1(nd_profile)
!           Term for thermal particular integral
      INTEGER &
          k_sol(nd_profile)
!           Index of eigenvalue closest to the cosine of the solar
!           zenith angle
      REAL  (RealK) :: &
          upm_c(nd_profile, 2*nd_red_eigensystem)
!           Weights for exponentials in conditioning term
!
!     Subroutines called:
!      EXTERNAL &
!          eig_sys, layer_part_integ, set_level_weights &
!        , set_dirn_weights, calc_surf_rad
!
!
!
!     Initialize the matrix.
      DO ie=1, 2*n_layer*n_red_eigensystem
        DO k=1, 6*n_red_eigensystem
          DO l=1, n_profile
            a(l, ie, k)=0.0e+00_RealK
          ENDDO
        ENDDO
      ENDDO
!
!     To keep track of the layers in which radiances are required
!     I_ASSIGN_LEVEL is used: we search for the layer containing this
!     level, as indicated by I_RAD_LAYER and set the elements of
!     WEIGHT_U for later use with the vector giving the complementary
!     function. The terms of the particular integral are assigned to
!     C_YLM. Initialize to look for the first level.
      i_assign_level=1
!
!     I_BELOW and I_ABOVE hold variables for the layers below and
!     above the current interface. They are flipped to enable us
!     to use arrays with a dimension of 2, without the need to copy
!     lots of data.
      i_below=1
!
!
!
!     Begin by determining the properties of the top layer.
      IF (ms == 0) THEN
        DO l=1, n_profile
          ss(l, ms)=1.0e+00_RealK-omega(l, 1)
          ssrt(l, ms)=sqrt(ss(l, ms))
        ENDDO
      ENDIF
      DO ls=max(1, ms), ls_trunc
        DO l=1, n_profile
          ss(l, ls)=1.0e+00_RealK-omega(l, 1)*phase_fnc(l, 1, ls)
          ssrt(l, ls)=sqrt(ss(l, ls))
        ENDDO
      ENDDO
!
!     Calculate the eigenvalues and eigenvectors for this layer.
      CALL eig_sys(n_profile, ls_trunc, ms, n_red_eigensystem &
        , cg_coeff, ssrt(1, 0) &
        , mu(1, 1, i_below), eig_vec(1, 1, 1, i_below) &
        , nd_profile, nd_red_eigensystem, nd_max_order &
        )
!
!     Calculate the exponential terms for this layer
      DO k=1, n_red_eigensystem
        DO l=1, n_profile
          theta(l, k, i_below)=exp(-tau(l, 1)/mu(l, k, i_below))
        ENDDO
      ENDDO
!
!     Find the particular integral in this layer.
      CALL layer_part_integ( &
          n_profile, ls_trunc, ms, n_red_eigensystem &
        , cg_coeff, mu(1, 1, i_below) &
        , eig_vec(1, 1, 1, i_below), theta(1, 1, i_below) &
        , isolir, i_direct(1, 0), mu_0, uplm_sol &
        , diff_planck(1, 1), l_ir_source_quad, diff_planck_2(1, 1) &
        , tau(1, 1), ss(1, 0) &
        , source_top(1, 1, i_below), source_bottom(1, 1, i_below) &
        , upm_c, k_sol, z_sol, q_0, q_1 &
        , nd_profile, nd_max_order, nd_red_eigensystem &
        )
!
!
!     Impose Marshak''s boundary conditions at the top of the atmosphere.
!     For each allowed order of l'' (LS_P, or LSR_P in the reduced
!     notation), those with odd parity, the integral of Y_l''^m and the
!     boundary condition on the radiance is formed and integrated over
!     the downward hemisphere.
!
      DO lsr_p=2, ls_trunc+1-ms, 2
!
        ie=lsr_p/2
!
!       Begin with the exceptional case in which l=l'' and KAPPA is 1/2.
        DO l=1, n_profile
          b(l, ie)=-0.5e+00_RealK*source_top(l, lsr_p, i_below)
        ENDDO
!       For other values of l, which must be odd when l'' is even and
!       vice versa, the precalculated values are used. A hemispherically
!       isotropic incident radiance may exist if l=m=0, so we this
!       case exceptionally, adjusting the beginning of the loop.
        IF (ms == 0) THEN
          DO l=1, n_profile
            b(l, ie)=b(l, ie)+kappa(lsr_p/2, 1) &
              *(2.0e+00_RealK*flux_down_inc(l)/sqrt(pi) &
              -source_top(l, 1, i_below))
          ENDDO
        ENDIF
        DO lsr=max(3-2*ms, 1), ls_trunc-ms, 2
          DO l=1, n_profile
            b(l, ie)=b(l, ie) &
              -kappa(lsr_p/2, (lsr+1)/2)*source_top(l, lsr, i_below)
          ENDDO
        ENDDO
!
!       Now calculate the coefficients of the matrix of unknowns,
!       u_{mik}^{+|-}.
        DO k=1, n_red_eigensystem
!         Variable numbers:
!         To accord with the general structure of the compressed matrix
!         the equations for the top boundary conditions are
!         right-justified by advancing the column by
!         2*N_RED_EIGENSYSTEM.
          ivmb=k+2*n_red_eigensystem
          ivpb=ivmb+n_red_eigensystem
!         In Marshak''s procedure, l'+m will be odd, so apart from
!         the term where l''=l, l+m will be even in all the non-zero
!         terms of the sum over l, so it is easy to obtain
!         A(L, IE, IVMB) by a simple subtraction from A(L, IE, IVPB).
!         Begin with the term l=l''.
          DO l=1, n_profile
            a(l, ie, ivpb)=0.5e+00_RealK*eig_vec(l, lsr_p, k, i_below)
          ENDDO
          DO ls=ms, ls_trunc-1, 2
            lsr=ls+1-ms
            DO l=1, n_profile
              a(l, ie, ivpb) &
                =a(l, ie, ivpb)+kappa(lsr_p/2, (lsr+1)/2) &
                *eig_vec(l, lsr, k, i_below)
            ENDDO
          ENDDO
          DO l=1, n_profile
            a(l, ie, ivmb) &
              =a(l, ie, ivpb)-eig_vec(l, lsr_p, k, i_below)
            a(l, ie, ivpb)=a(l, ie, ivpb)*theta(l, k, i_below)
          ENDDO
        ENDDO
      ENDDO
!
!     Set the weightings to be applied to the solution of the
!     linear system of equations.
      IF (i_sph_algorithm == IP_sph_direct) THEN
!       If we solve the problem directly the weightings will
!       apply to coefficients of the spherical harmonics.
!
!       The next test is done in two parts to ensure that it reamains
!       within bounds on I_RAD_LAYER.
        l_assign=(i_assign_level <= n_viewing_level)
        IF (l_assign) l_assign=(i_rad_layer(i_assign_level) == 1)
!
        CALL set_level_weights(1, n_profile, ls_trunc &
          , ms, n_red_eigensystem &
          , cg_coeff, mu(1, 1, i_below), eig_vec(1, 1, 1, i_below) &
          , isolir, z_sol(1, 1), mu_0 &
          , q_0, l_ir_source_quad, q_1 &
          , upm_c, k_sol &
          , tau, ss &
          , n_viewing_level, i_rad_layer, frac_rad_layer &
          , l_assign, i_assign_level &
          , c_ylm, weight_u(1, 1, 1, 1) &
          , nd_profile, nd_viewing_level &
          , nd_max_order &
          , nd_red_eigensystem, nd_sph_cf_weight &
          )
      ELSE IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
!       Here the weights couple directly to radiances in
!       particular directions.
        CALL set_dirn_weights(n_profile &
          , ms, ls_trunc, up_lm &
          , n_direction, mu_v, azim_factor &
          , n_viewing_level, i_rad_layer, frac_rad_layer, 1 &
          , n_red_eigensystem &
          , mu(1, 1, i_below), eig_vec(1, 1, 1, i_below) &
          , isolir, z_sol(1, 1), mu_0 &
          , l_ir_source_quad, diff_planck &
          , upm_c, k_sol &
          , tau, omega, phase_fnc &
          , weight_u(1, 1, 1, 1), radiance &
          , nd_profile, nd_layer, nd_direction, nd_viewing_level &
          , nd_red_eigensystem, nd_max_order &
          )
      ENDIF
!
!
!
!     For each interior level, 1,.., N_LAYER-1, continuity is imposed
!     on the (LS,MS)th component of the radiance field, for LS in the
!     range MS,..., LS_TRUNC (2*N_RED_EIGENSYSTEM orders). At each
!     stage we need information about the layers above and below the
!     layer. Arrays such as THETA therefore have an extra dimension of
!     size 2 to hold both values without the need to declare storage
!     for the whole column. To avoid copying values this last `index'' is
!     accessed using the variables I_ABOVE and I_BELOW which are
!     flipped as we pass through each layer. To follow the indexing
!     note that when the loop variable is I we are looking at the
!     I-1st interface.
!
      DO i=2, n_layer
!
!       Flip the indices for the layer above and below.
        i_above=i_below
        i_below=3-i_below
!
!       Calculate the condensed optical properties of the
!       current layer.
        IF (ms == 0) THEN
          DO l=1, n_profile
            ss(l, ms)=1.0e+00_RealK-omega(l, i)
            ssrt(l, ms)=sqrt(ss(l, ms))
          ENDDO
        ENDIF
        DO ls=max(1, ms), ls_trunc
          DO l=1, n_profile
            ss(l, ls)=1.0e+00_RealK-omega(l, i)*phase_fnc(l, i, ls)
            ssrt(l, ls)=sqrt(ss(l, ls))
          ENDDO
        ENDDO
!
!       Calculate the eigenvalues and eigenvectors for the current
!       layer which is that below the interface.
        CALL eig_sys(n_profile, ls_trunc, ms, n_red_eigensystem &
          , cg_coeff, ssrt(1, 0) &
          , mu(1, 1, i_below), eig_vec(1, 1, 1, i_below) &
          , nd_profile, nd_red_eigensystem, nd_max_order &
          )
!
!       Calculate the exponential terms for this layer
        DO k=1, n_red_eigensystem
          DO l=1, n_profile
             theta(l, k, i_below)=exp(-tau(l, i)/mu(l, k, i_below))
          ENDDO
        ENDDO
!
!       Find the particular integral in this layer.
        CALL layer_part_integ( &
            n_profile, ls_trunc, ms, n_red_eigensystem &
          , cg_coeff, mu(1, 1, i_below) &
          , eig_vec(1, 1, 1, i_below), theta(1, 1, i_below) &
          , isolir, i_direct(1, i-1), mu_0, uplm_sol &
          , diff_planck(1, i), l_ir_source_quad, diff_planck_2(1, i) &
          , tau(1, i), ss(1, 0) &
          , source_top(1, 1, i_below), source_bottom(1, 1, i_below) &
          , upm_c, k_sol, z_sol, q_0, q_1 &
          , nd_profile, nd_max_order, nd_red_eigensystem &
          )
!
!       Loop over the permitted orders of LS, compressing entries
!       into the matrix.
        DO lsr=1, 2*n_red_eigensystem
!
!         Number the equation:
          IF (mod(lsr, 2) == 1) THEN
            ie=n_red_eigensystem*(2*i-3)+(lsr+1)/2
          ELSE IF (mod(lsr, 2) == 0) THEN
            ie=n_red_eigensystem*(2*i-2)+lsr/2
          ENDIF
!
!         Loop over eigenvalues.
          DO k=1, n_red_eigensystem
!           Assign number to the variables in the equation
            ivma=k
            ivpa=ivma+n_red_eigensystem
            ivmb=ivpa+n_red_eigensystem
            ivpb=ivmb+n_red_eigensystem
            DO l=1, n_profile
              a(l, ie, ivma)=eig_vec(l, lsr, k, i_above) &
                *theta(l, k, i_above)*real(1-2*mod(lsr-1, 2), RealK)
              a(l, ie, ivpa)=eig_vec(l, lsr, k, i_above)
              a(l, ie, ivmb)=-eig_vec(l, lsr, k, i_below) &
                *real(1-2*mod(lsr-1, 2), RealK)
              a(l, ie, ivpb)=-eig_vec(l, lsr, k, i_below) &
                *theta(l, k, i_below)
            ENDDO
          ENDDO
!
          DO l=1, n_profile
            b(l, ie)=source_top(l, lsr, i_below) &
              -source_bottom(l, lsr, i_above)
          ENDDO
!
        ENDDO
!
        IF (i_sph_algorithm == IP_sph_direct) THEN
!         If we solve the problem directly the weightings will
!         apply to coefficients of the spherical harmonics.
!         An assignment is required only if there are remaining
!         viewing levels and we are in the right layer.
!
!         The next test is done in two parts to ensure that it reamains
!         within bounds on I_RAD_LAYER.
          l_assign=(i_assign_level <= n_viewing_level)
          IF (l_assign) l_assign=(i_rad_layer(i_assign_level) == i)
!
!         The different indexing of WEIGHT_U in the following two
!         calls is intentional. In the first case we interpolate
!         the radiance in one layer, so the final index runs only over
!         the eigensystem for that layer. In the second case, there
!         are contributions to the radiance at a particular level
!         from all layers, so the final index must be allow for
!         contributions from all layers.
!
          CALL set_level_weights(i, n_profile, ls_trunc &
            , ms, n_red_eigensystem &
            , cg_coeff, mu(1, 1, i_below), eig_vec(1, 1, 1, i_below) &
            , isolir, z_sol(1, 1), mu_0 &
            , q_0, l_ir_source_quad, q_1 &
            , upm_c, k_sol &
            , tau(1, i), ss &
            , n_viewing_level, i_rad_layer, frac_rad_layer &
            , l_assign, i_assign_level &
            , c_ylm, weight_u(1, 1, 1, 1) &
            , nd_profile, nd_viewing_level &
            , nd_max_order &
            , nd_red_eigensystem, nd_sph_cf_weight &
            )
        ELSE IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
!         Here the weights couple directly to radiances in
!         particular directions.
          CALL set_dirn_weights(n_profile &
            , ms, ls_trunc, up_lm &
            , n_direction, mu_v, azim_factor &
            , n_viewing_level, i_rad_layer, frac_rad_layer, i &
            , n_red_eigensystem &
            , mu(1, 1, i_below), eig_vec(1, 1, 1, i_below) &
            , isolir, z_sol(1, 1), mu_0 &
            , l_ir_source_quad, diff_planck &
            , upm_c, k_sol &
            , tau, omega, phase_fnc &
            , weight_u(1, 1, 1, 1+2*n_red_eigensystem*(i-1)), radiance &
            , nd_profile, nd_layer, nd_direction, nd_viewing_level &
            , nd_red_eigensystem, nd_max_order &
            )
        ENDIF
!
!
      ENDDO
!
!
!
!
!     Impose the surface boundary condition using the appropriate
!     bidirectional reflection functions with Marshak''s conditions.
!
!     Flip the `index'' to the layer above the interface.
      i_above=i_below
!
      DO lsr_p=2, ls_trunc+1-ms, 2
!
        ls_p=lsr_p+ms-1
!
        ie=n_red_eigensystem*(2*n_layer-1)+lsr_p/2
!
!       Initialize the RHS of the equations.
        DO l=1, n_profile
          b(l, ie)=0.0e+00_RealK
        ENDDO
!
!       Terms in this equation fall into two groups: those which
!       involve the BRDF and those which do not. These latter
!       terms, which arise directly from Marshak''s conditions
!       are treated first.
!
!       Begin with the exceptional case where l=l'' so KAPPA is 1/2.
        DO l=1, n_profile
          b(l, ie)=b(l, ie)-real(1-2*mod(ls_p, 2), RealK)*0.5e+00_realk &
            *source_bottom(l, lsr_p, i_above)
        ENDDO
        IF ( (isolir == IP_infra_red).AND.(ms == 0).and. &
             (lsr_p == 1) ) THEN
!         The Planckian flux is used instead of the radiance for
!         consistency with the two-stream equations.
          DO l=1, n_profile
            b(l, ie)=b(l, ie)+d_planck_flux_surface(l)/sqrt(pi)
          ENDDO
        ENDIF
!       For other values of l, which must be odd when l'' is even and
!       vice versa, the precalculated values are used.
        DO lsr=1, ls_trunc-ms, 2
          DO l=1, n_profile
            b(l, ie)=b(l, ie) &
              -real(1-2*mod(lsr+ms-1, 2), RealK) &
              *kappa(lsr_p/2, (lsr+1)/2) &
              *source_bottom(l, lsr, i_above)
          ENDDO
          IF ( (isolir == IP_infra_red).AND.(ms == 0).and. &
               (lsr == 1) ) THEN
            DO l=1, n_profile
              b(l, ie)=b(l, ie)+kappa(lsr_p/2, (lsr+1)/2) &
                *d_planck_flux_surface(l)*2.0e+00_RealK/sqrt(pi)
            ENDDO
          ENDIF
        ENDDO
!
!       Now calculate the coefficients of the matrix of unknowns,
!       u_{mik}^{+|-}.
        DO k=1, n_red_eigensystem
!         Variable numbers:
          ivma=k
          ivpa=ivma+n_red_eigensystem
!         KAPPA has not been calculated for those values of l for
!         which it is 0: we therefore add the terms in two groups,
!         firstly those for l=l'' and then those for other values of
!         l where KAPPA is non-zero. As at the top, of the atmosphere
!         it is possible to evaluate A(L, IE, IVMA) from
!         A(L, IE, IVPA)
          ls_p=lsr_p+ms-1
          DO l=1, n_profile
            a(l, ie, ivpa)=a(l, ie, ivpa)+real(1-2*mod(ls_p, 2), RealK) &
              *0.5e+00_RealK*eig_vec(l, lsr_p, k, i_above)
          ENDDO
          DO ls=ms, ls_trunc-1, 2
            lsr=ls+1-ms
            DO l=1, n_profile
              a(l, ie, ivpa)=a(l, ie, ivpa)+real(1-2*mod(ls, 2), RealK) &
                *kappa(lsr_p/2, (lsr+1)/2)*eig_vec(l, lsr, k, i_above)
            ENDDO
          ENDDO
!
          DO l=1, n_profile
            a(l, ie, ivma)=a(l, ie, ivpa)+real(1-2*mod(ms, 2), RealK) &
                *eig_vec(l, lsr_p, k, i_above)
          ENDDO
!
        ENDDO
!
!
!       The second group of terms involves the BRDF.
!       There will be no contribution from orders
!       above the order of trunction of the BRDF.
        IF (ms <= ls_brdf_trunc) THEN
!         Add in the solar or infra-red contributions involving the
!         BRDF basis functions which do not involve terms in KAPPA.
          IF (isolir == IP_solar) THEN
!
            DO j=1, n_brdf_basis_fnc
              DO l=1, n_profile
                b_factor(l)=0.0e+00_RealK
              ENDDO
              DO ls=ms, ls_brdf_trunc-mod(ms, 2), 2
                lsr=ls+1-ms
                ksi=kappa(lsr_p/2, 1)*f_brdf(j, 0, ls/2, ms)
                DO ls_d=ms+2, ls_brdf_trunc-mod(ms, 2), 2
                  lsr_d=ls_d-ms+1
                  ksi=ksi+kappa(lsr_p/2, (lsr_d+1)/2) &
                    *f_brdf(j, ls_d/2, ls/2, ms)
                ENDDO
                DO l=1, n_profile
                  b_factor(l)=b_factor(l)+ksi*uplm_sol(l, lsr)
                ENDDO
              ENDDO
              DO l=1, n_profile
                b(l, ie)=b(l, ie)+i_direct(l, n_layer)*mu_0(l) &
                  *real(1-2*mod(ms, 2), RealK) &
                  *rho_alb(l, j)*b_factor(l)
              ENDDO
            ENDDO
!
          ELSE IF (isolir == IP_infra_red) THEN
            IF (ms == 0) THEN
              DO j=1, n_brdf_basis_fnc
                lambda=0.0e+00_RealK
                DO ls_d=0, ls_brdf_trunc, 2
                  lsr_d=ls_d+1
                  lambda_d=0.0e+00_RealK
                  DO ls_dd=0, ls_brdf_trunc, 2
                    lsr_dd=ls_dd+1
                    lambda_d=lambda_d+kappa(lsr_p/2, (lsr_dd+1)/2) &
                      *f_brdf(j, ls_dd/2, ls_d/2, ms)
                  ENDDO
                  lambda=lambda+kappa(1, (lsr_d+1)/2)*lambda_d
                ENDDO
                DO l=1, n_profile
                  b(l, ie)=b(l, ie) &
                    +rho_alb(l, j)*lambda &
                    *sqrt(4.0e+00_RealK*pi/3.0e+00_realk) &
                    *d_planck_flux_surface(l)/pi
                ENDDO
              ENDDO
            ENDIF
          ENDIF
!
          DO ls=ms, ls_trunc
!
            lsr=ls+1-ms
!
            DO l=1, n_profile
              surface_term(l, lsr)=0.0e+00_RealK
            ENDDO
            DO j=1, n_brdf_basis_fnc
              phi=0.0e+00_RealK
              DO ls_d=ms, ls_brdf_trunc-mod(ms, 2), 2
                lsr_d=ls_d-ms+1
                phi_d=0.0e+00_RealK
                DO ls_dd=ms, ls_brdf_trunc-mod(ms, 2), 2
                  lsr_dd=ls_dd-ms+1
                  phi_d=phi_d+cgk((lsr_dd+1)/2, lsr) &
                    *f_brdf(j, ls_d/2, ls_dd/2, ms)
                ENDDO
                phi=phi+kappa(lsr_p/2, (lsr_d+1)/2)*phi_d
              ENDDO
              DO l=1, n_profile
                surface_term(l, lsr)=surface_term(l, lsr) &
                  +rho_alb(l, j)*phi*real(1-2*mod(ms, 2), RealK)
              ENDDO
            ENDDO
!
!           Add on the contribution to the RHS.
            DO l=1, n_profile
              b(l, ie)=b(l, ie) &
                -source_bottom(l, lsr, i_above)*surface_term(l, lsr)
            ENDDO
!           Add in the contributions to the matrix on the LHS.
            DO k=1, n_red_eigensystem
!             Variable numbers:
              ivma=k
              ivpa=ivma+n_red_eigensystem
              DO l=1, n_profile
                a(l, ie, ivma)=a(l, ie, ivma) &
                  +surface_term(l, lsr)*real(1-2*mod(lsr-1, 2), RealK) &
                  *eig_vec(l, lsr, k, i_above)
                a(l, ie, ivpa)=a(l, ie, ivpa) &
                  +surface_term(l, lsr)*eig_vec(l, lsr, k, i_above)
              ENDDO
!
            ENDDO
!
          ENDDO
!
        ENDIF
!
        DO k=1, n_red_eigensystem
          ivma=k
          DO l=1, n_profile
            a(l, ie, ivma)=a(l, ie, ivma)*theta(l, k, i_above)
          ENDDO
        ENDDO
!
      ENDDO
!
!
      IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
!       Calculate the contribution of radiation reflected from the
!       surface.
        CALL calc_surf_rad(n_profile, n_layer, tau &
          , ms, ls_trunc, euler_factor &
          , isolir, i_direct(1, n_layer), mu_0, d_planck_flux_surface &
          , n_brdf_basis_fnc, ls_brdf_trunc, f_brdf &
          , rho_alb, brdf_sol, brdf_hemi, cgk &
          , n_viewing_level, i_rad_layer, frac_rad_layer &
          , n_direction, mu_v, up_lm, azim_factor &
          , n_red_eigensystem, eig_vec(1, 1, 1, i_above) &
          , theta(1, 1, i_above), source_bottom(1, 1, i_above) &
          , radiance &
          , weight_u(1, 1, 1, 1+2*n_red_eigensystem*(n_layer-1)) &
          , nd_profile, nd_layer, nd_direction, nd_viewing_level &
          , nd_red_eigensystem, nd_max_order, nd_brdf_basis_fnc &
          , nd_brdf_trunc &
          )
!       Isotropic incident fluxes are permitted (and required in the
!       differential formulation of the IR).
        IF (ms == 0) THEN
          CALL calc_top_rad(n_profile, tau &
            , n_viewing_level, i_rad_layer, frac_rad_layer &
            , n_direction, mu_v &
            , flux_down_inc &
            , radiance &
            , nd_profile, nd_layer, nd_direction, nd_viewing_level &
            )
        ENDIF
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE BUILD_SPH_MATRIX
!+ Subroutine to calculate the arrays of BRDF terms.
!
! Purpose:
!   This routine is called to calculate a set of arrays related to
!   the BRDF for later efficiency.
!
! Method:
!   As this routine is called only once speed is not too critical
!   so direct calculation is used.
!
! Symmetries of the BRDF and storage:
!   Since the BRDF is defined only for downwelling incident radiances
!   and upwelling reflected radiances it cannot be uniquely defined
!   as a double expension in spherical harmonics. To make a unique
!   expansion we stipulate that only harmonics of even parity will
!   be used: if odd harmonics were chosen we would get into
!   difficulties with the Gibb''s phenomenon, as all odd harmonics
!   vanish on the horizontal.
!      F(j, l, l'', m) will therefore be 0 unless l+m and l'+m are
!   both even, so the indices of storage for l and l'' are set to
!   l/2 and l''/2. There are more efficient schemes of storage
!   that depend on the fact that F vanishes if l<m or l''<m, but such
!   a scheme has not been selected because of its extra complexity.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calc_brdf(isolir, ms_min, ms_max &
        , ia_sph_mm &
        , uplm_sol, uplm_zero &
        , n_brdf_basis_fnc, ls_brdf_trunc, f_brdf &
        , n_profile, n_direction, direction &
        , brdf_sol, brdf_hemi &
        , nd_profile, nd_radiance_profile, nd_direction &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
      USE spectral_region_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_radiance_profile &
!           Size allocated for profiles where radiances are calculated
        , nd_direction &
!           Size allocated for viewing directions
        , nd_max_order &
!           Size allcoated for polar orders
        , nd_sph_coeff &
!           Size allocated for spherical coefficients
        , nd_brdf_basis_fnc &
!           Size allocated for BRDF basis functions
        , nd_brdf_trunc
!           Size allocated for truncation of BRDFs
!
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile
!           Number of atmospheric profiles
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
      INTEGER, Intent(IN) :: &
          ms_min &
!           Lowest azimuthal order calculated
        , ms_max &
!           Highest azimuthal order calculated
        , ia_sph_mm(0: nd_max_order)
!           Address of spherical coefficient for (m, m) for each m
      REAL  (RealK), Intent(IN) :: &
          uplm_zero(nd_sph_coeff)
!           Array of Upsilon_l^m and derivatives at polar angles of pi/2
      INTEGER, Intent(IN) :: &
          n_brdf_basis_fnc &
!           Number of basis functions for BRDFs
        , ls_brdf_trunc
!           Order of truncation applied to BRDFs
      REAL  (RealK), Intent(IN) :: &
          f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc)
!           Array of moments of BRDF basis functions
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2) &
!           Cosines of polar viewing angles and actual azimuthal
!           viewing angles
        , uplm_sol(nd_profile, nd_sph_coeff)
!           Upsilon terms for solar radiation
!
      REAL  (RealK), Intent(OUT) :: &
          brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!
!     Local variables
      INTEGER &
          ls &
!           Polar order of harmonic
        , lsr &
!           Reduced polar order of harmonic
        , ls_p &
!           Polar order of harmonic
        , lsr_p &
!           Reduced polar order of harmonic
        , ms &
!           Azimuthal order of spherical harmonic
        , j &
!           Loop variable
        , l &
!           Loop variable
        , id
!           Loop variable
!
      REAL  (RealK) :: &
          up_lm(nd_profile, nd_brdf_trunc+1, nd_direction) &
!           Polar parts of spherical harmonics in the viewing
!           directions
        , ss1(nd_profile, 0: nd_brdf_trunc) &
!           Products of the BRDF and the solar harmonics
        , azim_factor(nd_profile, nd_direction) &
!           Azimuthal factors
        , kappa(nd_brdf_trunc+1) &
!           Hemispherical quadratic integrals of spherical harmonics
!           (reduced storage does not seem worth the effort here)
        , fk(nd_brdf_trunc+1)
!           Sum of products of the BRDF and KAPPA over l''
!
!     Subroutines called:
!      EXTERNAL &
!          eval_uplm
!
!
!
      IF (isolir == IP_solar) THEN
!
!       Initialize the BRDF for solar radiation
        DO id=1, n_direction
          DO j=1, n_brdf_basis_fnc
            DO l=1, n_profile
              brdf_sol(l, j, id)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDDO
!
!       Loop over azimuthal orders.
        DO ms=ms_min, min(ms_max, ls_brdf_trunc)
!
!         Caclulate the azimuthal factors.
          IF (ms == 0) THEN
            DO id=1, n_direction
              DO l=1, n_profile
                azim_factor(l, id)=1.0e+00_RealK
              ENDDO
            ENDDO
          ELSE
            DO id=1, n_direction
              DO l=1, n_profile
                azim_factor(l, id) &
                 =2.0e+00_RealK*cos(real(ms, realk)*direction(l, id, 2))
              ENDDO
            ENDDO
          ENDIF
!
!         Calculate spherical harmonics in the viewing directions
!         at this azimuthal order.
          DO id=1, n_direction
            CALL eval_uplm(ms, ls_brdf_trunc &
              , n_profile, direction(1, id, 1), up_lm(1, 1, id) &
              , nd_profile)
          ENDDO
!
!         Now loop over basis functions.
          DO j=1, n_brdf_basis_fnc
!
!           The array SS1 pulls in the solar dependence, which is
!           independent of the viewing direction. At this stage both
!           MS and J are fixed.
            DO ls=ms, ls_brdf_trunc, 2
              DO l=1, n_profile
                ss1(l, ls)=f_brdf(j, ls/2, ms/2, ms) &
                 *uplm_sol(l, ia_sph_mm(ms))
              ENDDO
              DO ls_p=ms+2, ls_brdf_trunc, 2
                DO l=1, n_profile
                  ss1(l, ls)=f_brdf(j, ls/2, ls_p/2, ms) &
                   *uplm_sol(l, ia_sph_mm(ms)+ls_p-ms)
                ENDDO
              ENDDO
            ENDDO
!
!           Now consider each direction, incrementing the solar
!           BRDF.
            DO id=1, n_direction
              DO ls=ms, ls_brdf_trunc, 2
                DO l=1, n_profile
                  brdf_sol(l, j, id)=brdf_sol(l, j, id) &
                    +ss1(l, ls)*up_lm(l, ls+1-ms, id) &
                    *azim_factor(l, id)
                ENDDO
              ENDDO
            ENDDO
!
          ENDDO
!
        ENDDO
!
      ELSE IF (isolir == IP_infra_red) THEN
!
!       Initialize.
        DO id=1, n_direction
          DO j=1, n_brdf_basis_fnc
            DO l=1, n_profile
              brdf_hemi(l, j, id)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDDO
!
!       Only azimuthally symmetric terms contribute.
        DO ms=ms_min, 0
!
          DO lsr_p=1, ls_brdf_trunc-ms+1, 2
            kappa(lsr_p)=2.0e+00_RealK*pi &
              *uplm_zero(ia_sph_mm(0)+lsr_p-1)*uplm_zero(2) &
              /real((lsr_p-2)*(lsr+1+2*ms), RealK)
          ENDDO
!
!         Calculate spherical harmonics in the viewing directions
!         at this azimuthal order.
          DO id=1, n_direction
            CALL eval_uplm(ms, ls_brdf_trunc &
              , n_profile, direction(1, id, 1), up_lm(1, 1, id) &
              , nd_profile)
          ENDDO
!
!         Now loop over basis functions.
          DO j=1, n_brdf_basis_fnc
!
            DO lsr=1, ls_brdf_trunc-ms+1, 2
              fk(lsr)=0.0e+00_RealK
              DO lsr_p=1, ls_brdf_trunc-ms+1, 2
                fk(lsr)=fk(lsr)+kappa(lsr_p) &
                  *f_brdf(j, (lsr-1+ms)/2, (lsr_p-1+ms)/2, ms)
              ENDDO
              DO id=1, n_direction
                DO l=1, n_profile
                  brdf_hemi(l, j, id)=brdf_hemi(l, j, id) &
                    +fk(lsr)*up_lm(l, lsr, id)
                ENDDO
              ENDDO
            ENDDO
!
          ENDDO
!
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE CALC_BRDF
!+ Subroutine to calculate spherical Clebsch-Gordan coefficients.
!
! Purpose:
!   The routine yields the Clebsch-Gordan coefficients between the
!   spherical harmonics Y_l^m and Y_1^0, c_{lm}^+ in the notation of
!   the description of the algorithm, or <l+1,m|1,0,l,m> in standard
!   notation. These are stored in one array with addressing determined
!   by the truncation.
!
! Method:
!   As this routine is called only once speed is not too critical
!   so direct calculation is used. Only values for m>0 are required.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calc_cg_coeff(ls_max_order &
        , ia_sph_mm, ms_min, ms_trunc &
        , cg_coeff &
        , nd_max_order, nd_sph_coeff)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_sph_coeff
!           Size of array of spherical coefficients
      INTEGER, Intent(IN) :: &
          ls_max_order &
!           Maximum order of harmonics required
        , ms_min &
!           Lowest azimuthal order calculated
        , ms_trunc(0: nd_max_order) &
!           Truncation in MS for this order
        , ia_sph_mm(0: nd_max_order)
!           Position of Clebsh-Gordan coefficient with m=0 for the
!           given value of l.
      REAL  (RealK), Intent(OUT) :: &
          cg_coeff(nd_sph_coeff)
!
!
!     Local variables
      INTEGER &
          ls &
!          Order of harmonic
        , ms
!           Azimuthal order of harmonic
      REAL  (RealK) :: &
          inv
!           l-dependent denominator
!
!
!
      DO ls=0, ls_max_order
        inv=1.0e+00_RealK/real((2*ls+1)*(2*ls+3), realk)
        DO ms=ms_min, ms_trunc(ls)
          cg_coeff(ia_sph_mm(ms)+ls-ms) &
            =sqrt(real((ls+1-ms)*(ls+1+ms), RealK)*inv)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE CALC_CG_COEFF
!+ Subroutine to calculate monochromatic fluxes using IPA.
!
! Method:
!
!   In this subroutine a long vector for two-stream flux calculations
!   is set up using the information on the types of cloud present.
!
! Current owner of code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First version under RCS
!                                               (J. M. Edwards)
!
! Description of code:
!   Fortran 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calc_flux_ipa(ierr &
!                        Atmospheric Properties
        , n_profile, n_layer, n_cloud_top &
!                        Options for Equivalent Extinction
        , l_scale_solar, adjust_solar_ke &
!                        Algorithmic options
        , i_2stream, i_solver &
!                        Spectral Region
        , isolir &
!                        Infra-red Properties
        , diff_planck &
        , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
        , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                        Conditions at Surface
        , d_planck_flux_surface, rho_alb &
!                       Optical Properties
        , ss_prop &
!                        Cloud Geometry
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Calculated fluxes
        , flux_direct, flux_total &
!                        Options for clear-sky fluxes
        , l_clear, i_solver_clear &
!                       Calculated fluxes
        , flux_direct_clear, flux_total_clear &
!                        Dimensions of Arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_profile_column, nd_source_coeff &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE def_std_io_icf
      USE spectral_region_pcf
      USE surface_spec_pcf
      USE solver_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_layer_clr &
!           Size allocated for totally clear atmospheric layers
        , nd_column &
!           Size allocated for columns at a grid-point
        , nd_profile_column &
!           Number of profiles of subcolumns considered at once
        , id_ct &
!           Topmost declared cloudy layer
        , nd_source_coeff
!           Number of coefficients in the source function
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Topmost cloudy layer
!
      INTEGER, Intent(IN) :: &
          isolir &
!           Spectral region
        , i_2stream &
!           Two-stream scheme selected
        , i_solver
!           Solver selected
      LOGICAL, Intent(IN) :: &
          l_scale_solar &
!           Scale solar beam
        , l_ir_source_quad
!           Use a quadratic source term
!           the singly scattered solar beam
!
!     Fields for equivalent extinction
      REAL  (RealK), Intent(IN) :: &
          adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment of solar beam with equivalent extinction
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!     Planckian terms:
      REAL  (RealK), Intent(IN) :: &
          diff_planck(nd_profile, nd_layer) &
!           Change in Planckian function
        , diff_planck_2(nd_profile, nd_layer) &
!           Twice 2nd differences in Planckian
        , d_planck_flux_surface(nd_profile)
!           Differential Planckian flux from the surface
!
!     Conditions at TOA
      REAL  (RealK), Intent(IN) :: &
          sec_00(nd_profile, nd_layer) &
!           Secant of zenith angle
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , flux_inc_down(nd_profile)
!           Incident total flux
!
!     Conditions at surface
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, 2)
!           Weights of the basis functions
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
          area_column(nd_profile, nd_column)
!           Area of each column
!
!                       Calculated Fluxes
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Direct Flux
        , flux_total(nd_profile, 2*nd_layer+2)
!           Total Fluxes
!
!                        Options for clear-sky fluxes
      LOGICAL &
          l_clear
!           Flag for clear-sky fluxes
      INTEGER &
          i_solver_clear
!           Solver selected for clear-sky fluxes
!                       Calculated clear-sky fluxes
      REAL  (RealK), Intent(OUT) :: &
          flux_direct_clear(nd_profile, 0: nd_layer) &
!           Direct Clear-sky Flux
        , flux_total_clear(nd_profile, 2*nd_layer+2)
!           Total Clear-sky Flux
!
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l &
!           Loop variable
        , lp &
!           Index of current real grid-point during assignments
        , ll &
!           Index in the long array of columns to be taken in one go
        , ll_copy &
!           Index of column to be copied
        , icl &
!           Index of notional sub-column
        , ics &
!           Index of current sub-column where a solution is required
        , icc &
!           Temporary variable listing the layer in the current column
!           where a change is required
        , ict
!           Temporary variable listing the type of optical region moved
!           into be the current change
      INTEGER &
          n_long &
!           Length of long vector
        , target(nd_profile_column)
!           Actual target grid-point for point in the long array
      REAL  (RealK) :: &
          weight_long(nd_profile_column)
!           Weight applied to each column in the sum
      LOGICAL &
          l_new
!           Flag to consider a new grid-point
!
!     Properties of vectors of subcolumns
      REAL  (RealK) :: &
          tau_long(nd_profile_column, nd_layer) &
!           Long vector of optical depth
        , omega_long(nd_profile_column, nd_layer) &
!           Long vector of albedo of single scattering
        , asymmetry_long(nd_profile_column, nd_layer) &
!           Long vector of asymmetries
        , adjust_solar_ke_long(nd_profile_column, nd_layer) &
!           Long vector of solar scalings
        , sec_00_long(nd_profile_column, nd_layer) &
!           Long vector of cosines of the solar zenith angle
        , diff_planck_long(nd_profile_column, nd_layer) &
!           Long vector of differences in the Planckian
        , diff_planck_2_long(nd_profile_column, nd_layer) &
!           Long vector of second differences in the Planckian
        , flux_inc_direct_long(nd_profile_column) &
!           Long vector of incident direct downward fluxes
        , flux_inc_down_long(nd_profile_column) &
!           Long vector of incident downward fluxes
        , d_planck_flux_surface_long(nd_profile_column) &
!           Long vector of differential Planckian fluxes
!           at the surface
        , rho_alb_long(nd_profile_column, 2)
!           Long vector of weightings of BRDF basis functions
!
!     Calculated Fluxes in subcolumns
      REAL  (RealK) :: &
          flux_direct_long(nd_profile_column, 0: nd_layer) &
!           Direct Flux
        , flux_total_long(nd_profile_column, 2*nd_layer+2)
!           Total Fluxes
!
!     Clear-sky optical properties of the whole column
      REAL  (RealK), Allocatable :: &
          tau_clr_f(:, :) &
!           Clear-sky optical depth for the whole column
        , omega_clr_f(:, :) &
!           Clear-sky albedos of single scattering for the whole column
        , phase_fnc_clr_f(:, :, :)
!           Moments of the clear-sky phase function for the whole column
!
!
!
!
!     Functions called:
!
!     Subroutines called:
!      EXTERNAL &
!          two_stream
!
!
!
!     Zero the output arrays ready for incrementing.
!
      DO i=1, 2*n_layer+2
        DO l=1, n_profile
          flux_total(l, i)=0.0e+00_RealK
        ENDDO
      ENDDO
!
      IF (isolir == IP_solar) THEN
        DO i=0, n_layer
          DO l=1, n_profile
            flux_direct(l, i)=0.0e+00_RealK
          ENDDO
        ENDDO
      ENDIF
!
!
!     Start feeding points into the long array. This is
!     not written to vectorize as that is quite complicated.
!
      lp=1
      l_new=.true.
!
      DO while (lp <= n_profile)
!
        ll=0
!
        DO while ( (ll < nd_profile_column).AND.(lp <= n_profile) )
!
          ll=ll+1
          target(ll)=lp
!
          IF (l_new) THEN
!
!           We consider a new grid-point and so must set the first
!           notional column which is contains no cloud.
            icl=1
            ics=1
            DO i=1, n_cloud_top-1
              tau_long(ll, i)=ss_prop%tau_clr(lp, i)
              omega_long(ll, i)=ss_prop%omega_clr(lp, i)
              asymmetry_long(ll, i)=ss_prop%phase_fnc_clr(lp, i, 1)
            ENDDO
            DO i=n_cloud_top, n_layer
              tau_long(ll, i)=ss_prop%tau(lp, i, 0)
              omega_long(ll, i)=ss_prop%omega(lp, i, 0)
              asymmetry_long(ll, i)=ss_prop%phase_fnc(lp, i, 1, 0)
            ENDDO
!
            l_new=.false.
!
!
          ELSE
!
!           Copy the previous column over. Normally this will be the
!           previous one, but if we are starting a new batch it will
!           be the one at the end of the previous batch.
            IF (ll > 1) THEN
              ll_copy=ll-1
            ELSE
              ll_copy=n_long
            ENDIF
!
            DO i=1, n_layer
              tau_long(ll, i)=tau_long(ll_copy, i)
              omega_long(ll, i)=omega_long(ll_copy, i)
              asymmetry_long(ll, i) &
                =asymmetry_long(ll_copy, i)
            ENDDO
!
          ENDIF
!
!         Move through the notional columns at this grid-point
!         adjusting individiual layers until we find one where the
!         equations are to be solved.
          DO while (icl < list_column_slv(lp, ics))
            icc=i_clm_lyr_chn(lp, icl)
            ict=i_clm_cld_typ(lp, icl)
!
            tau_long(ll, icc)=ss_prop%tau(lp, icc, ict)
            omega_long(ll, icc)=ss_prop%omega(lp, icc, ict)
            asymmetry_long(ll, icc) &
              =ss_prop%phase_fnc(lp, icc, 1, ict)
!
            icl=icl+1
          ENDDO
!
!
!         Set arrays which are independent of cloud changes.
          IF (isolir == IP_solar) THEN
!
            IF (l_scale_solar) THEN
              DO i=1, n_layer
                adjust_solar_ke_long(ll, i)=adjust_solar_ke(lp, i)
              ENDDO
            ENDIF
!
            sec_00_long(ll,:)=sec_00(lp,:)
            flux_inc_direct_long(ll)=flux_inc_direct(lp)
            d_planck_flux_surface_long(ll)=0.0e+00_RealK
!
          ELSE IF (isolir == IP_infra_red) THEN
!
            d_planck_flux_surface_long(ll) &
              =d_planck_flux_surface(lp)
            DO i=1, n_layer
              diff_planck_long(ll, i)=diff_planck(lp, i)
            ENDDO
            IF (l_ir_source_quad) THEN
              DO i=1, n_layer
                diff_planck_2_long(ll, i)=diff_planck_2(lp, i)
              ENDDO
            ENDIF
!
          ENDIF
!
          flux_inc_down_long(ll)=flux_inc_down(lp)
          rho_alb_long(ll, IP_surf_alb_dir) &
            =rho_alb(lp, IP_surf_alb_dir)
          rho_alb_long(ll, IP_surf_alb_diff) &
            =rho_alb(lp, IP_surf_alb_diff)
!
!         The curent notional column will contain the fraction of
!         the grid-box required for incrementing.
          weight_long(ll)=area_column(lp, icl)
!
!
!         Prepare for the next column, moving on to the next grid-point
!         as required.
          ics=ics+1
          IF (ics > n_column_slv(lp)) THEN
            lp=lp+1
            l_new=.true.
          ENDIF
!
        ENDDO
!
!       Set N_LONG which will be required for the next batch after LL
!       has been reset.
        n_long=ll
!
!
!       N.B. The clear-sky option cannot be used here.
        CALL two_stream(ierr &
!                       Atmospheric properties
          , n_long, n_layer &
!                       Two-stream scheme
          , i_2stream &
!                       Options for solver
          , i_solver &
!                       Options for equivalent extinction
          , l_scale_solar, adjust_solar_ke_long &
!                       Spectral region
          , isolir &
!                       Infra-red properties
          , diff_planck_long &
          , l_ir_source_quad, diff_planck_2_long &
!                       Conditions at TOA
          , flux_inc_down_long, flux_inc_direct_long, sec_00_long & !hmjb
!                       Surface conditions
          , rho_alb_long(1, IP_surf_alb_diff) &
          , rho_alb_long(1, IP_surf_alb_dir), d_planck_flux_surface_long &
!                       Single scattering properties
          , tau_long, omega_long, asymmetry_long(1, 1) &
!                       Fluxes calculated
          , flux_direct_long, flux_total_long &
!                       Sizes of arrays
          , nd_profile_column, nd_layer, nd_source_coeff &
          )
!
!
!
!       Scatter the calculated fluxes back to their
!       appropriate grid-points.
!
        DO i=1, 2*n_layer+2
          DO ll=1, n_long
            l=target(ll)
            flux_total(l, i)=flux_total(l, i) &
              +weight_long(ll)*flux_total_long(ll, i)
          ENDDO
        ENDDO
!
        IF (isolir == IP_solar) THEN
          DO i=0, n_layer
            DO ll=1, n_long
              l=target(ll)
              flux_direct(l, i)=flux_direct(l, i) &
                +weight_long(ll)*flux_direct_long(ll, i)
            ENDDO
          ENDDO
        ENDIF
!
!
      ENDDO
!
!     Calculate the clear-sky fluxes if required.
      IF (l_clear) THEN
!
!       Set aside space for the clear optical properties and copy
!       them across.
        ALLOCATE(tau_clr_f(nd_profile, nd_layer))
        ALLOCATE(omega_clr_f(nd_profile, nd_layer))
        ALLOCATE(phase_fnc_clr_f(nd_profile, nd_layer, 1))
!
        CALL copy_clr_full(n_profile, n_layer, n_cloud_top, 1 &
          , ss_prop%tau_clr, ss_prop%omega_clr, ss_prop%phase_fnc_clr &
          , ss_prop%tau, ss_prop%omega, ss_prop%phase_fnc &
          , tau_clr_f, omega_clr_f, phase_fnc_clr_f &
!                       Sizes of arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct, 1 &
          )
!
        CALL two_stream(ierr &
!                       Atmospheric properties
          , n_profile, n_layer &
!                       Two-stream scheme
          , i_2stream &
!                       Options for solver
          , i_solver_clear &
!                       Options for equivalent extinction
          , l_scale_solar, adjust_solar_ke &
!                       Spectral region
          , isolir &
!                       Infra-red properties
          , diff_planck &
          , l_ir_source_quad, diff_planck_2 &
!                       Conditions at TOA
          , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                       Surface conditions
          , rho_alb(1, IP_surf_alb_diff) &
          , rho_alb(1, IP_surf_alb_dir), d_planck_flux_surface &
!                       Single scattering properties
          , tau_clr_f, omega_clr_f, phase_fnc_clr_f(1, 1, 1) &
!                       Fluxes calculated
          , flux_direct_clear, flux_total_clear &
!                       Sizes of arrays
          , nd_profile, nd_layer, nd_source_coeff &
          )
!
!       Remove the arrays that are no longer required.
        DEALLOCATE(tau_clr_f)
        DEALLOCATE(omega_clr_f)
        DEALLOCATE(phase_fnc_clr_f)
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE CALC_FLUX_IPA
!+ Subroutine to calculate monochromatic radiances using IPA.
!
! Method:
!
!   In this subroutine a long vector for radiance calculations
!   is set up using the information on the types of cloud present.
!
! Current owner of code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First version under RCS
!                                               (J. M. Edwards)
!
! Description of code:
!   Fortran 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calc_radiance_ipa(ierr &
!                        Atmospheric Properties
        , n_profile, n_layer, n_cloud_top &
!                       Angular Integration
        , n_order_phase, ms_min, ms_max, ls_local_trunc &
        , i_truncation, accuracy_adaptive, euler_factor &
        , i_sph_algorithm, i_sph_mode, l_rescale &
!                       Precalculated angular arrays
        , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Options for Equivalent Extinction
        , l_scale_solar, adjust_solar_ke &
!                        Spectral Region
        , isolir &
!                        Infra-red Properties
        , diff_planck &
        , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
        , flux_inc_down, zen_0 &
!                        Conditions at Surface
        , d_planck_flux_surface &
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
!                       Optical Properties
        , ss_prop &
!                        Cloud Geometry
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
        , n_direction, direction &
!                       Calculated fluxes or radiances
        , flux_direct, flux_total, i_direct, radiance, j_radiance &
!                        Dimensions of Arrays
        , nd_profile, nd_layer &
        , nd_column &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc &
        , nd_red_eigensystem, nd_sph_equation, nd_sph_diagonal &
        , nd_sph_cf_weight, nd_sph_u_range &
        , nd_viewing_level, nd_direction &
        , nd_profile_column &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE def_std_io_icf
      USE spectral_region_pcf
      USE sph_mode_pcf
      USE sph_algorithm_pcf
      USE solver_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_flux_profile &
!           Size allocated for profiles of output fluxes
        , nd_radiance_profile &
!           Size allocated for profiles of radiances
        , nd_j_profile &
!           Size allocated for profiles of photolysis rates
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_column &
!           Size allocated for columns at a grid-point
        , nd_viewing_level &
!           Size allowed for levels where the radiance is calculated
        , nd_max_order &
!           Size allowed for orders of spherical harmonics
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for orders of BRDFs
        , nd_sph_coeff &
!           Size allowed for spherical harmonic coefficients
        , nd_red_eigensystem &
!           Size allowed for the spherical harmonic eigensystem
        , nd_sph_equation &
!           Size allowed for spherical harmonic equations
        , nd_sph_diagonal &
!           Size allowed for diagonals of the spherical harmonic
!           matrix
        , nd_sph_cf_weight &
!           Size allowed for application of weights of the C. F.
        , nd_sph_u_range &
!           Size allowed for range of values of u^+|- contributing
!           on any viewing level
        , nd_direction &
!           Size allocated for viewing dierctions
        , nd_profile_column 
!           Number of profiles of subcolumns considered at once
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Topmost cloudy layer
        , n_order_phase
!           Number of orders retained in the phase function
!
!                        Spherical arrays
      INTEGER, Intent(IN) :: &
          ms_min &
!           Lowest azimuthal order calculated
        , ms_max &
!           Highest azimuthal order calculated
        , i_truncation &
!           Type of speherical truncation
        , i_sph_mode &
!           Mode in which the spherical harmonic solver is used
        , i_sph_algorithm &
!           Spherical harmonic algorithm
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient for (m, m) for each m
        , ls_local_trunc(0: nd_max_order)
!           Orders of truncation at each azimuthal order
      REAL  (RealK) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-Gordan coefficients
        , uplm_zero(nd_sph_coeff) &
!           Values of spherical harmonics at polar angles pi/2
        , uplm_sol(nd_profile, nd_sph_coeff)
!           Values of spherical harmonics in the solar direction
      REAL  (RealK), Intent(IN) :: &
          accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last term of an alternating series
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
      LOGICAL, Intent(IN) :: &
          l_scale_solar &
!           Scale solar beam
        , l_ir_source_quad &
!           Use a quadratic source term
        , l_rescale
!           Flag for rescaling of the optical properties
!
!     Fields for equivalent extinction
      REAL  (RealK), Intent(IN) :: &
          adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment of solar beam with equivalent extinction
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere/
!
!     Planckian terms:
      REAL  (RealK), Intent(IN) :: &
          diff_planck(nd_profile, nd_layer) &
!           Change in Planckian function
        , diff_planck_2(nd_profile, nd_layer) &
!           Twice 2nd differences in Planckian
        , d_planck_flux_surface(nd_profile)
!           Differential Planckian flux from the surface
!
!     Conditions at TOA
      REAL  (RealK), Intent(IN) :: &
          zen_0(nd_profile) &
!           Secant of zenith angle
        , flux_inc_down(nd_profile)
!           Incident total flux
!
!     Conditions at surface
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of trunation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
          area_column(nd_profile, nd_column)
!           Area of each column
!
!                        Levels at which radiances will be calculated
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2)
!           Viewing directions
!
!                       Calculated Fluxes or Radiances
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_profile, 0: nd_layer)
!           Direct radiances
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct Flux
        , flux_total(nd_flux_profile, 2*nd_layer+2) &
!           Total Fluxes
        , radiance(nd_radiance_profile, nd_viewing_level, nd_direction) &
!           Radiances
        , j_radiance(nd_j_profile, nd_viewing_level)
!           Photolysis rates
!
!
!
!     Local variables.
      INTEGER &
          ls &
!           Polar order of harmonic
        , ms &
!           Azimuthal order of harmonic
        , i &
!           Loop variable
        , j &
!           Loop variable
        , js &
!           Loop variable
        , l &
!           Loop variable
        , id &
!           Loop variable
        , lp &
!           Index of current real grid-point during assignments
        , ll &
!           Index in the long array of columns to be taken in one go
        , ll_copy &
!           Index of column to be copied
        , icl &
!           Index of notional sub-column
        , ics &
!           Index of current sub-column where a solution is required
        , icc &
!           Temporary variable listing the layer in the current column
!           where a change is required
        , ict
!           Temporary variable listing the type of optical region moved
!           into be the current change
      INTEGER &
          n_long &
!           Length of long vector
        , target(nd_profile_column)
!           Actual target grid-point for point in the long array
      REAL  (RealK) :: &
          weight_column(nd_profile_column)
!           Weight applied to each column in the sum
      LOGICAL &
          l_new
!           Flag to consider a new grid-point
!
!     Properties of vectors of subcolumns
      REAL  (RealK) :: &
          tau_long(nd_profile_column, nd_layer) &
!           Long vector of optical depth
        , omega_long(nd_profile_column, nd_layer) &
!           Long vector of albedo of single scattering
        , phase_fnc_long(nd_profile_column, nd_layer, nd_max_order) &
!           Long vector of phase functions
        , phase_fnc_solar_long(nd_profile_column &
            , nd_layer, nd_direction) &
!           Long vector of solar phase functions
        , forward_scatter_long(nd_profile_column, nd_layer) &
!           Long vector of forward scattering fractions
        , adjust_solar_ke_long(nd_profile_column, nd_layer) &
!           Long vector of solar scalings
        , zen_0_long(nd_profile_column) &
!           Long vector of cosines of the solar zenith angle
        , uplm_sol_long(nd_profile_column, nd_sph_coeff) &
!           Long vector of spherical harmonics at the solar angle
        , diff_planck_long(nd_profile_column, nd_layer) &
!           Long vector of differences in the Planckian
        , diff_planck_2_long(nd_profile_column, nd_layer) &
!           Long vector of second differences in the Planckian
        , flux_inc_down_long(nd_profile_column) &
!           Long vector of incident downward fluxes
        , d_planck_flux_surface_long(nd_profile_column) &
!           Long vector of differential Planckian fluxes
!           at the surface
        , rho_alb_long(nd_profile_column, nd_brdf_basis_fnc) &
!           Long vector of weightings of BRDF basis functions
        , brdf_sol_long(nd_profile_column, nd_brdf_basis_fnc &
            , nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi_long(nd_profile_column, nd_brdf_basis_fnc &
            , nd_direction) &
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
        , direction_long(nd_profile_column, nd_direction, 2)
!           Viewing directions
!
!     Calculated Fluxes or Radiances in subcolumns
      REAL  (RealK) :: &
          flux_direct_column(nd_profile_column, 0: nd_layer) &
!           Direct Flux
        , flux_total_column(nd_profile_column, 2*nd_layer+2) &
!           Total Fluxes
        , i_direct_column(nd_profile_column, 0: nd_layer) &
!           Direct radiances
        , radiance_column(nd_profile_column, nd_viewing_level &
            , nd_direction) &
!           Radiances
        , photolysis_column(nd_profile_column, nd_viewing_level)
!           Photolysis rates
!
!
!
!
!     Functions called:
!
!     Subroutines called:
!      EXTERNAL &
!          sph_solver
!
!
!
!     Zero the output arrays ready for incrementing.
      IF (i_sph_mode == IP_sph_mode_flux) THEN
!
        DO i=1, 2*n_layer+2
          DO l=1, n_profile
            flux_total(l, i)=0.0e+00_RealK
          ENDDO
        ENDDO
!
        IF (isolir == IP_solar) THEN
          DO i=0, n_layer
            DO l=1, n_profile
              flux_direct(l, i)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDIF
!
      ELSE
!
        DO id=1, n_direction
          DO i=1, n_viewing_level
            DO l=1, n_profile
              radiance(l, i, id)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDDO
!
        DO i=1, n_viewing_level
          DO l=1, n_profile
            j_radiance(l, i)=0.0e+00_RealK
          ENDDO
        ENDDO
!
        IF (isolir == IP_solar) THEN
!         The top level contains the input: other values are zeroed
!         to allow incrementing.
          DO i=1, n_layer
            DO l=1, n_profile
              i_direct(l, i)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDIF
!
!
      ENDIF
!
!
!     Start feeding points into the long array. This is
!     not written to vectorize as that is quite complicated.
!
      lp=1
      l_new=.true.
!
      DO while (lp <= n_profile)
!
        ll=0
!
        DO while ( (ll < nd_profile_column).AND.(lp <= n_profile) )
!
          ll=ll+1
          target(ll)=lp
!
          IF (l_new) THEN
!
!           We consider a new grid-point and so must set the first
!           notional column which is contains no cloud.
            icl=1
            ics=1
            DO i=1, n_cloud_top-1
              tau_long(ll, i)=ss_prop%tau_clr(lp, i)
              omega_long(ll, i)=ss_prop%omega_clr(lp, i)
              DO ls=1, n_order_phase
                phase_fnc_long(ll, i, ls) &
                  =ss_prop%phase_fnc_clr(lp, i, ls)
              ENDDO
            ENDDO
            DO i=n_cloud_top, n_layer
              tau_long(ll, i)=ss_prop%tau(lp, i, 0)
              omega_long(ll, i)=ss_prop%omega(lp, i, 0)
              DO ls=1, n_order_phase
                phase_fnc_long(ll, i, ls) &
                  =ss_prop%phase_fnc(lp, i, ls, 0)
              ENDDO
            ENDDO
            IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
              DO id=1, n_direction
                DO i=1, n_cloud_top-1
                  phase_fnc_solar_long(ll, i, id) &
                    =ss_prop%phase_fnc_solar_clr(lp, i, id)
                ENDDO
                DO i=n_cloud_top, n_layer
                  phase_fnc_solar_long(ll, i, id) &
                    =ss_prop%phase_fnc_solar(lp, i, id, 0)
                ENDDO
              ENDDO
              IF (l_rescale) THEN
                DO i=1, n_cloud_top-1
                  forward_scatter_long(ll, i) &
                    =ss_prop%forward_scatter_clr(lp, i)
                ENDDO
                DO i=n_cloud_top, n_layer
                  forward_scatter_long(ll, i) &
                    =ss_prop%forward_scatter(lp, i, 0)
                ENDDO
              ENDIF
            ENDIF
!
!
            l_new=.false.
!
!
          ELSE
!
!           Copy the previous column over. Normally this will be the
!           previous one, but if we are starting a new batch it will
!           be the one at the end of the previous batch.
            IF (ll > 1) THEN
              ll_copy=ll-1
            ELSE
              ll_copy=n_long
            ENDIF
!
            DO i=1, n_layer
              tau_long(ll, i)=tau_long(ll_copy, i)
              omega_long(ll, i)=omega_long(ll_copy, i)
              DO ls=1, n_order_phase
                phase_fnc_long(ll, i, ls) &
                  =phase_fnc_long(ll_copy, i, ls)
              ENDDO
            ENDDO
            IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
              DO id=1, n_direction
                DO i=1, n_layer
                  phase_fnc_solar_long(ll, i, id) &
                    =phase_fnc_solar_long(ll_copy, i, id)
                ENDDO
              ENDDO
              IF (l_rescale) THEN
                DO i=1, n_layer
                  forward_scatter_long(ll, i) &
                    =forward_scatter_long(ll_copy, i)
                ENDDO
              ENDIF
            ENDIF
!
          ENDIF
!
!         Move through the notional columns at this grid-point
!         adjusting individiual layers until we find one where the
!         equations are to be solved.
          DO while (icl < list_column_slv(lp, ics))
            icc=i_clm_lyr_chn(lp, icl)
            ict=i_clm_cld_typ(lp, icl)
!
            tau_long(ll, icc)=ss_prop%tau(lp, icc, ict)
            omega_long(ll, icc)=ss_prop%omega(lp, icc, ict)
            DO ls=1, n_order_phase
              phase_fnc_long(ll, icc, ls) &
                =ss_prop%phase_fnc(lp, icc, ls, ict)
            ENDDO
            IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
              DO id=1, n_direction
                phase_fnc_solar_long(ll, icc, id) &
                  =ss_prop%phase_fnc_solar(lp, icc, id, ict)
              ENDDO
              IF (l_rescale) THEN
                forward_scatter_long(ll, icc) &
                  =ss_prop%forward_scatter(lp, icc, ict)
              ENDIF
            ENDIF
!
            icl=icl+1
          ENDDO
!
!
!         Set arrays which are independent of cloud changes.
          IF (isolir == IP_solar) THEN
!
            IF (l_scale_solar) THEN
              DO i=1, n_layer
                adjust_solar_ke_long(ll, i)=adjust_solar_ke(lp, i)
              ENDDO
            ENDIF
!
            zen_0_long(ll)=zen_0(lp)
            i_direct_column(ll, 0)=i_direct(lp, 0)
            DO ms=ms_min, ms_max
              DO ls=ms, ls_local_trunc(ms)+1
                js=ia_sph_mm(ms)+ls-ms
                uplm_sol_long(ll, js)=uplm_sol(lp, js)
              ENDDO
            ENDDO
!
            IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
              DO id=1, n_direction
                DO j=1, n_brdf_basis_fnc
                  brdf_sol_long(ll, j, id)=brdf_sol(lp, j, id)
                ENDDO
              ENDDO
            ENDIF
!
          ELSE IF (isolir == IP_infra_red) THEN
!
            d_planck_flux_surface_long(ll) &
              =d_planck_flux_surface(lp)
            DO i=1, n_layer
              diff_planck_long(ll, i)=diff_planck(lp, i)
            ENDDO
            IF (l_ir_source_quad) THEN
              DO i=1, n_layer
                diff_planck_2_long(ll, i)=diff_planck_2(lp, i)
              ENDDO
            ENDIF
            IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
              DO id=1, n_direction
                DO j=1, n_brdf_basis_fnc
                  brdf_hemi_long(ll, j, id)=brdf_hemi(lp, j, id)
                ENDDO
              ENDDO
            ENDIF
!
          ENDIF
!
!         Set the viewing directions.
          IF (i_sph_mode == IP_sph_mode_rad) THEN
            DO id=1, n_direction
              direction_long(ll, id, 1)=direction(lp, id, 1)
              direction_long(ll, id, 2)=direction(lp, id, 2)
            ENDDO
          ENDIF
!
          flux_inc_down_long(ll)=flux_inc_down(lp)
          DO js=1, n_brdf_basis_fnc
            rho_alb_long(ll, js)=rho_alb(lp, js)
          ENDDO
!
!         The curent notional column will contain the fraction of
!         the grid-box required for incrementing.
          weight_column(ll)=area_column(lp, icl)
!
!
!         Prepare for the next column, moving on to the next grid-point
!         as required.
          ics=ics+1
          IF (ics > n_column_slv(lp)) THEN
            lp=lp+1
            l_new=.true.
          ENDIF
!
        ENDDO
!
!       Set N_LONG which will be required for the next batch after LL
!       has been reset.
        n_long=ll
!
!
        CALL sph_solver(ierr &
!                       Atmospheric sizes
          , n_long, n_layer &
!                       Angular integration
          , ms_min, ms_max, i_truncation, ls_local_trunc &
          , cg_coeff, uplm_zero, ia_sph_mm &
          , accuracy_adaptive, euler_factor &
          , i_sph_algorithm, i_sph_mode &
!                       Spectral Region
          , isolir &
!                       Options for Equivalent Extinction
          , l_scale_solar, adjust_solar_ke_long &
!                       Solar Fields
          , i_direct_column, zen_0_long, uplm_sol_long &
!                       Infra-red Properties
          , diff_planck_long, flux_inc_down_long &
          , l_ir_source_quad, diff_planck_2_long &
!                       Optical properies
          , tau_long, omega_long, phase_fnc_long &
          , phase_fnc_solar_long &
!                       Surface Conditions
          , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb_long &
          , f_brdf, brdf_sol_long, brdf_hemi_long &
          , d_planck_flux_surface_long &
!                       Levels for calculating radiances
          , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
          , n_direction, direction_long &
!                       Calculated Radiances or Fluxes
          , flux_direct_column, flux_total_column, radiance_column &
          , photolysis_column &
!                       Dimensions of arrays
          , nd_profile_column, nd_layer &
          , nd_profile_column, nd_profile_column, nd_profile_column &
          , nd_max_order, nd_sph_coeff &
          , nd_brdf_basis_fnc, nd_brdf_trunc &
          , nd_red_eigensystem, nd_sph_equation, nd_sph_diagonal &
          , nd_sph_cf_weight, nd_sph_u_range &
          , nd_viewing_level, nd_direction &
          )
!
!
!
!       Scatter the calculated fluxes or radiances back to their
!       appropriate grid-points.
        IF (i_sph_mode == IP_sph_mode_flux) THEN
!
          DO i=1, 2*n_layer+2
            DO ll=1, n_long
              l=target(ll)
              flux_total(l, i)=flux_total(l, i) &
                +weight_column(ll)*flux_total_column(ll, i)
            ENDDO
          ENDDO
!
          IF (isolir == IP_solar) THEN
            DO i=0, n_layer
              DO ll=1, n_long
                l=target(ll)
                flux_direct(l, i)=flux_direct(l, i) &
                  +weight_column(ll)*flux_direct_column(ll, i)
              ENDDO
            ENDDO
          ENDIF
!
        ELSE
!
          DO id=1, n_direction
            DO i=1, n_viewing_level
              DO ll=1, n_long
                l=target(ll)
                radiance(l, i, id)=radiance(l, i, id) &
                  +weight_column(ll)*radiance_column(ll, i, id)
              ENDDO
            ENDDO
          ENDDO
!
          DO i=1, n_viewing_level
            DO ll=1, n_long
              l=target(ll)
              j_radiance(l, i)=j_radiance(l, i) &
                +weight_column(ll)*photolysis_column(ll, i)
            ENDDO
          ENDDO
!
          IF (isolir == IP_solar) THEN
            DO i=1, n_layer
              DO ll=1, n_long
                l=target(ll)
                i_direct(l, i)=i_direct(l, i) &
                  +weight_column(ll)*i_direct_column(ll, i)
              ENDDO
            ENDDO
          ENDIF
!
        ENDIF
!
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE CALC_RADIANCE_IPA
!+ Subroutine to set weights for the C.F. at the surface
!
! Purpose:
!   The contribution to the radiance of radiation reflected from the
!   surface is evaluated.
!
! Method:
!   The iterated expression for the radiance involves a contribution
!   from the radiance reflected from the surface. In principle, this
!   could be provided by the upward radiance, but in practice this
!   would be of low accuracy since the spherical harmonic series for
!   the radiance will be noisy at low orders of truncation. It is
!   better to evaluate the reflected radiance using the BRDFs, even
!   though it is more expensive to do so; this ensures that no
!   radiation will appear to be reflected from a non-reflecting
!   surface. Given these constraints the algorithm is essentially
!   straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calc_surf_rad(n_profile, n_layer, tau &
        , ms, ls_trunc, euler_factor &
        , isolir, i_direct_surf, mu_0, d_planck_flux_surface &
        , n_brdf_basis_fnc, ls_brdf_trunc, f_brdf &
        , rho_alb, brdf_sol, brdf_hemi, cgk &
        , n_viewing_level, i_rad_layer, frac_rad_layer &
        , n_direction, mu_v, up_lm, azim_factor &
        , n_red_eigensystem, eig_vec, theta, source_base &
        , radiance, weight_u &
        , nd_profile, nd_layer, nd_direction, nd_viewing_level &
        , nd_red_eigensystem, nd_max_order, nd_brdf_basis_fnc &
        , nd_brdf_trunc &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!
!     Dummy arguments.
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_direction &
!           Size allocated for viewing directions
        , nd_red_eigensystem &
!           Size allocated for the reduced eigensystem
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_brdf_basis_fnc &
!           Size allocated for basis functions of BRDFs
        , nd_brdf_trunc
!           Size allocated for orders in basis functions of BRDFs
!
!
!     The atmosphere:
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric profiles
        , n_layer
!           Number of atmospheric layers
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, nd_layer)
!           Optical depths
!
!     Controlling spherical orders:
      INTEGER, Intent(IN) :: &
          ms &
!           Current azimuthal order
        , ls_trunc
!           Order of polar truncation
      REAL  (RealK), Intent(IN) :: &
          euler_factor
!           Factor applied to the last term of the series
!
!     Variables for solar or thermal sources
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
      REAL  (RealK), Intent(IN) :: &
          i_direct_surf(nd_profile) &
!           The direct solar radiance at the surface
        , mu_0(nd_profile)
!           Cosines of the solar zenith angle
      REAL  (RealK), Intent(IN) :: &
          d_planck_flux_surface(nd_profile)
!           Differential Planckian flux at the surface
!
!     Variables related to the BRDFs
      INTEGER, Intent(IN) :: &
          n_brdf_basis_fnc &
!           Number of basis functions used in BRDFs
        , ls_brdf_trunc
!           Order of polar truncation applied to BRDFs
      REAL  (RealK), Intent(IN) :: &
          f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           BRDF basis functions
        , rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of applied to the basis functions of the BRDF
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
      REAL  (RealK), Intent(IN) :: &
          cgk(nd_brdf_trunc/2+1, nd_max_order)
!           Integrals of pairs of spherical harmonics over the downward
!           hemisphere

!
!     Viewing geometry:
      INTEGER, Intent(IN) :: &
          n_direction &
!           Number of directions
        , n_viewing_level &
!           Number of levels where the radiance is calculated
        , i_rad_layer(nd_viewing_level)
!           Indices of layers containing viewing levels
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level) &
!           Fraction optical depth into its layer of the
!           radiance level
        , mu_v(nd_profile, nd_direction) &
!           Cosines of polar viewing angles
        , azim_factor(nd_profile, nd_direction) &
!           Azimuthal factors
        , up_lm(nd_profile, nd_max_order+1, nd_direction)
!           Spherical harmonics at a fixed azimuthal order
!
      INTEGER, Intent(IN) :: &
          n_red_eigensystem
!           Size of the reduced eigensystem
      REAL  (RealK), Intent(IN) :: &
          eig_vec(nd_profile, 2*nd_red_eigensystem &
            , nd_red_eigensystem) &
!           Eigenvalues of the full eigensystem scaled by
!           the s-parameters
        , theta(nd_profile, nd_red_eigensystem) &
!           Array of exponentials of optical depths along slant paths
        , source_base(nd_profile, ls_trunc+1-ms)
!           Source function at the bottom of the layer
!
!
      REAL  (RealK), Intent(INOUT) :: &
          radiance(nd_profile, nd_viewing_level, nd_direction)
!           Radiances (to be incremented by the contribution of
!           the particular integral)
      REAL  (RealK), Intent(INOUT) :: &
          weight_u(nd_profile, nd_viewing_level &
            , nd_direction, 2*nd_red_eigensystem)
!           Weights for the coefficients in the complementary
!           function
!
!
!     Local variables
      INTEGER &
          l &
!           Loop variable (points)
        , ir &
!           Loop variable (viewing levels)
        , id &
!           Loop variable (directions)
        , j &
!           Loop variable
        , k &
!           Loop variable
        , i &
!           Loop variable
        , ll
!           Loop variable
      INTEGER &
          ls &
!           Loop variable (polar orders)
        , lsr &
!           Loop variable (reduced polar orders)
        , ls_d &
!           Loop variable (polar orders)
        , lsr_d &
!           Loop variable (reduced polar orders)
        , ls_dd &
!           Loop variable (polar orders)
        , lsr_dd
!           Loop variable (reduced polar orders)
      INTEGER &
          n_list_up &
!           Number of points where the viewing direction is upward
        , list_up(nd_profile)
!           List of points where the viewing direction is upward
      REAL  (RealK) :: &
          trans(nd_profile) &
!           Tranmission along the line of sight from the surface
!           to the viewing level
        , x
!           Temporary variable
!     Working arrays realated to the BRDF:
      REAL  (RealK) :: &
          xy(nd_profile) &
!           Product of (Clebsch-Gordan coefficient * kappa) and
!           the spherical harmonic at the current order in the
!           viewing direction
        , ryx(nd_profile, ls_trunc-ms+1) &
!           Sum over basis functions of products of the above
!           and albedo weights
        , rvyx_m(nd_profile, nd_red_eigensystem) &
!           Sum over polar orders of product of RYX and elements
!           of the eigenvalue for each eigenvalue for application
!           to terms in negative exponentials
        , rvyx_p(nd_profile, nd_red_eigensystem) &
!           Sum over polar orders of product of RYX and elements
!           of the eigenvalue for each eigenvalue for application
!           to terms in positive exponentials
        , rsyx(nd_profile) &
!           Sum over polar orders of product of RYX and elements
!           of the source function
        , brdf_full(nd_profile)
!           Full BRDF weighted and summed over all basis functions
!
!
!
!     For each direction and observing level we calculate the
!     contribution of the particular integral to the radiance
!     from the surface and appropriate weightings for the
!     complementary function.
      DO id=1, n_direction
!
!       Collect upward directions.
        n_list_up=0
        DO l=1, n_profile
          IF (mu_v(l, id) > 0.0e+00_RealK) THEN
            n_list_up=n_list_up+1
            list_up(n_list_up)=l
          ENDIF
        ENDDO
!
!       Calculate the angular arrays related to the BRDF. At higher
!       azimuthal orders there will be contributions because all
!       terms of the BRDF that would contribute are beyond the
!       level of truncation and so are zero.
!
        IF (ms <= ls_brdf_trunc-mod(ms, 2)) THEN
!
          DO j=1, n_brdf_basis_fnc
            DO ls=ms, ls_trunc
              lsr=ls-ms+1
              DO ls_d=ms, ls_brdf_trunc-mod(ms, 2), 2
                lsr_d=ls_d-ms+1
                x=0.0e+00_RealK
                DO ls_dd=ms, ls_brdf_trunc-mod(ms, 2), 2
                  lsr_dd=ls_dd-ms+1
                  x=x-cgk((lsr_dd+1)/2, lsr)*f_brdf(j, ls_d, ls_dd, ms)
                ENDDO
                IF (ls_d == ms) THEN
!                 Initialize this time.
                  DO l=1, n_profile
                    xy(l)=x*up_lm(l, lsr_d, id)
                  ENDDO
                ELSE
!                 Now add the increments.
                  DO l=1, n_profile
                    xy(l)=xy(l)+x*up_lm(l, lsr_d, id)
                  ENDDO
                ENDIF
              ENDDO
              IF (j == 1) THEN
!               Initialize this time.
                DO l=1, n_profile
                  ryx(l, lsr)=rho_alb(l, 1)*xy(l)
                ENDDO
              ELSE
!               Increment for subsequent basis functions.
                DO l=1, n_profile
                  ryx(l, lsr)=ryx(l, lsr)+rho_alb(l, j)*xy(l)
                ENDDO
              ENDIF
            ENDDO
          ENDDO
!
          DO k=1, n_red_eigensystem
            DO l=1, n_profile
              x=euler_factor*ryx(l, ls_trunc-ms+1) &
                *eig_vec(l, ls_trunc-ms+1, k)
              rvyx_m(l, k)=x
              rvyx_p(l, k)=x
            ENDDO
            DO lsr= ls_trunc-ms, 1, -1
              DO l=1, n_profile
                x=ryx(l, lsr)*eig_vec(l, lsr, k)
                rvyx_m(l, k)=rvyx_m(l, k) &
                  +x*real(1-2*mod(lsr-1, 2), RealK)
                rvyx_p(l, k)=rvyx_p(l, k)+x
              ENDDO
            ENDDO
            DO l=1, n_profile
              rvyx_m(l, k)=rvyx_m(l, k)*theta(l, k)
            ENDDO
          ENDDO
!
          DO l=1, n_profile
            rsyx(l)=euler_factor*ryx(l, ls_trunc-ms+1) &
              *source_base(l, ls_trunc-ms+1)
          ENDDO
          DO lsr= ls_trunc-ms, 1, -1
            DO l=1, n_profile
              rsyx(l)=rsyx(l)+ryx(l, lsr)*source_base(l, lsr)
            ENDDO
          ENDDO
!
        ENDIF
!
!
        DO ir=1, n_viewing_level
!
!         Calculate minus the slantwise transmission from the
!         surface to the level in question. TRANS is used is
!         hold intermediate results.
          DO ll=1, n_list_up
            l=list_up(ll)
            trans(l) &
              =(1.0e+00_RealK &
              -frac_rad_layer(ir))*tau(l, i_rad_layer(ir))
          ENDDO
          DO i=i_rad_layer(ir)+1, n_layer
            DO ll=1, n_list_up
              l=list_up(ll)
              trans(l)=trans(l)+tau(l, i)
            ENDDO
          ENDDO
          DO ll=1, n_list_up
            l=list_up(ll)
            trans(l) &
              =exp(-trans(l)/mu_v(l, id))
          ENDDO
!
!         Add in the terms from the BRDF if in range.
          IF (ms <= ls_brdf_trunc-mod(ms,2)) THEN
!
            DO ll=1, n_list_up
              l=list_up(ll)
!             Add the contribution from the source function at the
!             base of the layer.
              radiance(l, ir, id)=radiance(l, ir, id) &
                +trans(l)*rsyx(l)*azim_factor(l, id)
            ENDDO
!
!           Increment the weights applied to the complementary function.
            DO k=1, n_red_eigensystem
              DO ll=1, n_list_up
                l=list_up(ll)
                weight_u(l, ir, id, k)=weight_u(l, ir, id, k) &
                  +trans(l)*rvyx_m(l, k)
                weight_u(l, ir, id, k+n_red_eigensystem) &
                  =weight_u(l, ir, id, k+n_red_eigensystem) &
                  +trans(l)*rvyx_p(l, k)
              ENDDO
            ENDDO
!
          ENDIF
!
!
!         Add the direct solar or thermal contributions to the radiance.
!         The azimuthal dependencies are included in the solar and
!         hemispheric parts of the BRDF, so the should be added in just
!         once, most naturally at the zeroth order.
          IF (ms == 0) THEN
            IF (isolir == IP_solar) THEN
              DO ll=1, n_list_up
                l=list_up(ll)
                brdf_full(l)=rho_alb(l, 1)*brdf_sol(l, 1, id)
              ENDDO
              DO j=2, n_brdf_basis_fnc
                DO ll=1, n_list_up
                  l=list_up(ll)
                  brdf_full(l)=brdf_full(l) &
                    +rho_alb(l, j)*brdf_sol(l, j, id)
                ENDDO
              ENDDO
              DO ll=1, n_list_up
                l=list_up(ll)
                radiance(l, ir, id)=radiance(l, ir, id) &
                  +trans(l)*i_direct_surf(l)*mu_0(l) &
                  *brdf_full(l)
              ENDDO
            ELSE IF (isolir == IP_infra_red) THEN
              DO ll=1, n_list_up
                l=list_up(ll)
                brdf_full(l)=rho_alb(l, 1)*brdf_hemi(l, 1, id)
              ENDDO
              DO j=2, n_brdf_basis_fnc
                DO ll=1, n_list_up
                  l=list_up(ll)
                  brdf_full(l)=brdf_full(l) &
                    +rho_alb(l, j)*brdf_hemi(l, j, id)
                ENDDO
              ENDDO
              DO ll=1, n_list_up
                l=list_up(ll)
                radiance(l, ir, id)=radiance(l, ir, id) &
                  +trans(l) &
                  *(1.0e+00_RealK-brdf_full(l)) &
                  *d_planck_flux_surface(l)/pi
              ENDDO
            ENDIF
          ENDIF
!
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE CALC_SURF_RAD
!+ Subroutine to increment radiances for radiation from the top.
!
! Purpose:
!   The contribution to the solution of radiances transmitted from
!   the top boundary is evaluated. In the IR where differential
!   radiances are used the radiance at the top will be the Planckian
!   radiance at that temperature. In idealized tests an incident
!   flux may be prescribed.
!
! Method:
!   Straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calc_top_rad(n_profile, tau &
        , n_viewing_level, i_rad_layer, frac_rad_layer &
        , n_direction, mu_v &
        , flux_inc_down &
        , radiance &
        , nd_profile, nd_layer, nd_direction, nd_viewing_level &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!
!     Dummy arguments.
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_direction
!           Size allocated for viewing directions
!
!
!     The atmosphere:
      INTEGER, Intent(IN) :: &
          n_profile
!           Number of atmospheric profiles
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, nd_layer)
!           Optical depths
!
!     Viewing geometry:
      INTEGER, Intent(IN) :: &
          n_direction &
!           Number of directions
        , n_viewing_level &
!           Number of levels where the radiance is calculated
        , i_rad_layer(nd_viewing_level)
!           Indices of layers containing viewing levels
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level) &
!           Fraction optical depth into its layer of the
!           viewing level
        , mu_v(nd_profile, nd_direction)
!           Cosines of polar viewing angles
      REAL  (RealK), Intent(IN) :: &
          flux_inc_down(nd_profile)
!           Isotropic incident flux
!
      REAL  (RealK), Intent(INOUT) :: &
          radiance(nd_profile, nd_viewing_level, nd_direction)
!           Radiances (to be incremented by the contribution of
!           the particular integral)
!
!     Local variables
      INTEGER &
          l &
!           Loop variable (points)
        , iv &
!           Loop variable (viewing levels)
        , id &
!           Loop variable (directions)
        , i &
!           Loop variable
        , ll
!           Loop variable
      INTEGER &
          n_list_down &
!           Number of points where the viewing direction is upward
        , list_down(nd_profile)
!           List of points where the viewing direction is upward
      REAL  (RealK) :: &
          tau_c(nd_profile, nd_viewing_level)
!           Cumulative optical depths to the viewing level
!
!
!
!     Calculate the cumulative optical depth from the
!     top of the atmosphere to each viewing level.
      DO iv=1, n_viewing_level
!
        DO l=1, n_profile
          tau_c(l, iv) &
            =frac_rad_layer(iv)*tau(l, i_rad_layer(iv))
        ENDDO
        DO i=i_rad_layer(iv)-1, 1, -1
          DO l=1, n_profile
            tau_c(l, iv)=tau_c(l, iv)+tau(l, i)
          ENDDO
        ENDDO
!
      ENDDO
!
!
      DO id=1, n_direction
!
!       Collect downward directions.
        n_list_down=0
        DO l=1, n_profile
          IF (mu_v(l, id) < 0.0e+00_RealK) THEN
            n_list_down=n_list_down+1
            list_down(n_list_down)=l
          ENDIF
        ENDDO
!
        DO iv=1, n_viewing_level
          DO ll=1, n_list_down
            l=list_down(ll)
            radiance(l, iv, id)=radiance(l, iv, id) &
              +(flux_inc_down(l)/pi)*exp(tau_c(l, iv)/mu_v(l, id))
          ENDDO
        ENDDO
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE CALC_TOP_RAD
!+ Subroutine to calculate densities.
!
! Method:
!        This routine calculates the density of air and the molar
!        densities of the broadening species for the self and foreign-
!        broadened continua using the gas law including the effect
!        of water vapour.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calculate_density(n_profile, n_layer, l_continuum &
         , water_frac, p, t, i_top &
         , density, molar_density_water, molar_density_frn &
         , nd_profile, nd_layer &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE physical_constants_0_ccf
      USE physical_constants_1_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer
!           Maximum number of layers
!






!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , i_top
!           Top vertical `index''
      LOGICAL &
          l_continuum
!           Continuum flag
      REAL  (RealK), Intent(IN) :: &
          water_frac(nd_profile, nd_layer) &
!           Mass fraction of water
        , p(nd_profile, nd_layer) &
!           Pressure
        , t(nd_profile, nd_layer)
!           Temperature
      REAL  (RealK), Intent(OUT) :: &
          density(nd_profile, nd_layer) &
!           Air density
        , molar_density_water(nd_profile, nd_layer) &
!           Molar density of water
        , molar_density_frn(nd_profile, nd_layer)
!           Molar density of foreign species
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i
!           Loop variable
!
!
!
!     find the air density first.
      DO i=1, nd_layer
        DO l=1, nd_profile
           density(l, i)=p(l, i)/(r_gas_dry*t(l, i) &
             *(1.0e+00_RealK+(ratio_molar_weight-1.00e+00_realk) &
             *water_frac(l, i)))
        ENDDO
      ENDDO
!
      IF (l_continuum) THEN
        DO i=1, nd_layer
          DO l=1, nd_profile
            molar_density_frn(l, i)=density(l, i) &
              *(1.0e+00_RealK-water_frac(l, i))/mol_weight_air

            molar_density_water(l, i)=density(l, i) &
              *water_frac(l, i)*(ratio_molar_weight/mol_weight_air)





          ENDDO
        ENDDO
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE CALCULATE_DENSITY
!+ Subroutine to calculate Upsilon_l^m(0) for the solar direction.
!
! Purpose:
!   This routine is called to determine the values of spherical
!   harmonics in the solar direction.
!
! Method:
!   As this routine is called only once speed is not too critical
!   so direct calculation is used.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calc_uplm_sol(n_profile, ms_min, ms_max, ia_sph_mm &
        , ls_local_trunc, zen_0, uplm_sol &
        , nd_profile, nd_max_order, nd_sph_coeff)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_sph_coeff &
!           Number of spherical coefficients
        , nd_max_order
!           Maximum order of calculation
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric profiles
        , ms_min &
!           Lowest azimuthal order calculated
        , ms_max &
!           Highest azimuthal order calculated
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical oefficient for (m, m) for each m
        , ls_local_trunc(0: nd_max_order)
!           Local truncation at this order
      REAL  (RealK), Intent(IN) :: &
          zen_0(nd_profile)
!           Cosines of solar zenith angles
      REAL  (RealK), Intent(OUT) :: &
          uplm_sol(nd_profile, nd_sph_coeff)
!           Array of Upsilon_l^m evaluated in the solar direction.
!
!
!     Local variables
      INTEGER &
          ls &
!           Order of harmonic
        , ms &
!           Azimuthal quantum number of harmonic
        , j &
!           Temporary address
        , k &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          product &
!           Factorial terms of Y_lm
        , lsr &
!           Real polar order of harmonic
        , msr
!           Real azimuthal order of harmonic
!
!
!
!     Note here that ZEN_0 holds the cosine of the zenith angle, so
!     the cosine of the solar direction is actually -ZEN_0.
      DO ms=ms_min, ms_max
!
!       Calculate Upsilon_m^m(n_sol) to start the recurrence.
        j=ia_sph_mm(ms)
!
        product=1.0e+00_RealK
        msr=real(ms, RealK)
        IF (ms > 0) THEN
          DO k=1, ms
            product=(1.0e+00_RealK-5.0e-01_realk/real(k, realk))*product
          ENDDO
          DO l=1, n_profile
            uplm_sol(l, j)=(-1.0e+00_RealK)**ms &
              *sqrt((1.0e+00_RealK-zen_0(l)*zen_0(l))**ms*product &
              *(2.0e+00_RealK*msr+1.0e+00_realk)/(4.0e+00_realk*pi))
          ENDDO
        ELSE
          DO l=1, n_profile
            uplm_sol(l, j)=1.0e+00_RealK/sqrt(4.0e+00_realk*pi)
          ENDDO
        ENDIF
!
!       Calculate the next polar order to enable the recurrence to
!       start.
        IF (ms <= ls_local_trunc(ms)+1) THEN
          DO l=1, n_profile
            uplm_sol(l, j+1) &
              =-zen_0(l)*sqrt(2.0e+00_RealK*msr &
              +3.0e+00_RealK)*uplm_sol(l, j)
          ENDDO
        ENDIF
!
!       Complete the recurrence on l.
        DO ls=ms+2, ls_local_trunc(ms)+1
          j=ia_sph_mm(ms)+ls-ms
          lsr=real(ls, RealK)
          DO l=1, n_profile
            uplm_sol(l, j) &
              =sqrt(((2.0e+00_RealK*lsr-1.0e+00_realk) &
              *(2.0e+00_RealK*lsr+1.0e+00_realk)) &
              /((lsr+msr)*(lsr-msr))) &
              *(-zen_0(l))*uplm_sol(l, j-1) &
              -sqrt(((2.0e+00_RealK*lsr+1.0e+00_realk) &
              *(lsr-1.0e+00_RealK-msr)*(lsr-1.0e+00_realk+msr)) &
              /((2.0e+00_RealK*lsr-3.0e+00_realk) &
              *(lsr-msr)*(lsr+msr)))*uplm_sol(l, j-2)
          ENDDO
        ENDDO
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE CALC_UPLM_SOL
!+ Subroutine to calculate Upsilon_l^m(0) or its derivative.
!
! Purpose:
!   This routine is called to determine the value of a spherical
!   harmonic with theta=pi/2 and phi=0 or the derivative for
!   alternate orders. This minimizes storage.
!
! Method:
!   As this routine is called only once speed is not too critical
!   so direct calculation is used.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE calc_uplm_zero(ms_min, ms_max, ia_sph_mm &
        , ls_local_trunc, uplm_zero &
        , nd_max_order, nd_sph_coeff)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          nd_sph_coeff &
!           Number of spherical coefficients
        , nd_max_order
!           Maximum order of calculation
      INTEGER, Intent(IN) :: &
          ms_min &
!           Lowest azimuthal order calculated
        , ms_max &
!           Highest azimuthal order calculated
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient for (m, m) for each m
        , ls_local_trunc(0: nd_max_order)
!           Local truncation at this order
      REAL  (RealK), Intent(OUT) :: &
          uplm_zero(nd_sph_coeff)
!           Array of Upsilon_l^m and derivatives at polar angles of pi/2
!
!
!     Local variables
      INTEGER &
          ls &
!           Order of harmonic
        , ms &
!           Azimuthal quantum number of harmonic
        , j &
!           Temporary address
        , k
!           Loop variable
!
!
!
      DO ms=ms_min, ms_max
!
!       Calculate Upsilon_m^m(0) to start the recurrence.
        j=ia_sph_mm(ms)
        uplm_zero(j)=1.0e+00_RealK/(4.0e+00_realk*pi)
        DO k=3, 2*ms+1, 2
           uplm_zero(j)=uplm_zero(j)*real(k, RealK)/real(k-1, realk)
        ENDDO
        uplm_zero(j)=real(1-2*mod(ms, 2), RealK)*sqrt(uplm_zero(j))
!
!
!       Calculate DUpsilon_{m+1}^m(0) to start the recurrence for the
!       derivatives.
        j=j+1
        uplm_zero(j)=3.0e+00_RealK/(4.0e+00_realk*pi)
        DO k=5, 2*ms+3, 2
           uplm_zero(j)=uplm_zero(j)*real(k, RealK)/real(k-3, realk)
        ENDDO
        uplm_zero(j)=real(1-2*mod(ms, 2), RealK)*sqrt(uplm_zero(j))
!
!       Now apply the recurrence formulae:
        DO ls=ms+2, ls_local_trunc(ms)-1, 2
          j=ia_sph_mm(ms)+ls-ms
!
!         Recurrence for Upsilon_l^m.
          uplm_zero(j)=-uplm_zero(j-2) &
            *sqrt(real((2*ls+1)*(ls+ms-1)*(ls-ms-1), RealK) &
            /real((2*ls-3)*(ls+ms)*(ls-ms), RealK))
!
!         Recurrence for the derivative Upsilon_(l+1)^m.
          uplm_zero(j+1)=-uplm_zero(j-1) &
            *sqrt(real((2*ls+3)*(ls+1+ms)*(ls+1-ms), RealK) &
            /real((2*ls-1)*(ls+ms)*(ls-ms), RealK))
!
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE CALC_UPLM_ZERO
!+ Subroutine to calculate the product of CG and KAPPA.
!
! Purpose:
!   This routine calculates a sum of products of hemispheric
!   integrals and Clebsch-Gordan coefficients used in the
!   specification of BRDFs. These terms might be stored, but
!   this could involve the use of too much memory.
!
! Method:
!
!
!   Indexing is a bit complicated. The BRDF is truncated at an
!   even order and l''+m and l+m must both be even, so the effective
!   truncation when m is odd is one order lower. Nominally,
!   CGK is CGK(l'',l) where l' takes alternate values though l takes
!   consecutive values, so we map into the actual array as
!       (l'', l) --> ( (l'-m+2)/2, (l-m+1) )
!
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE cg_kappa_ms(ms, ls_trunc, ls_brdf_trunc &
        , cg_coeff, kappa &
        , cgk &
        , nd_max_order, nd_brdf_trunc &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_brdf_trunc
!           Size allocated for orders of spherical harmonics
!           in BRDFs
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          ms &
!           Azimuthal order
        , ls_trunc &
!           The order of truncation applied to spherical harmonics
        , ls_brdf_trunc
!           The order of truncation applied to the BRDF
      REAL  (RealK), Intent(IN) :: &
          cg_coeff(ls_trunc-ms+1) &
!           Clebsch-Gordan coefficients
        , kappa(nd_max_order/2, nd_max_order/2)
!           Integrals of pairs of spherical harmonics over the downward
!           hemisphere
!
      REAL  (RealK), Intent(OUT) :: &
          cgk(nd_brdf_trunc/2+1, nd_max_order)
!           Integrals of pairs of spherical harmonics over the downward
!           hemisphere
!
!     Local variables:
      INTEGER &
          lsr_p &
!           Reduced primed polar order
        , lsr
!           Reduced polar order
!
!
!
!     Consider first the case where l+m is even. In this case the
!     documented formula is applied directly, with the omission
!     of a term in the first element of the array where l'' would
!     be out of range.
      DO lsr=1, ls_trunc+1-ms, 2
        cgk(1, lsr)=cg_coeff(1)*kappa(1, (lsr+1)/2)
        DO lsr_p=3, ls_brdf_trunc-ms+1-mod(ms, 2), 2
          cgk((lsr_p+1)/2, lsr) &
            =cg_coeff(lsr_p)*kappa((lsr_p+1)/2, (lsr+1)/2) &
            +cg_coeff(lsr_p-1)*kappa((lsr_p-1)/2, (lsr+1)/2)
        ENDDO
      ENDDO
!     In the case where l+m is odd the array is generally zero, so
!     we initialize all such values and calculate exceptional cases
!     later. Note that KAPPA does not appear in these loops because
!     in the compressed format these trivially evaluated values are
!     not stored.
      DO lsr=2, ls_trunc+1-ms, 2
        DO lsr_p=1, ls_brdf_trunc-ms+1-mod(ms, 2), 2
          cgk((lsr_p+1)/2, lsr)=0.0e+00_RealK
        ENDDO
      ENDDO
!     The case l=l''+1:
      DO lsr=2, ls_brdf_trunc-ms-mod(ms, 2)+2, 2
        cgk(lsr/2, lsr)=cg_coeff(lsr-1)*0.5e+00_RealK
      ENDDO
!     The case l=l''-1:
      DO lsr=2, ls_brdf_trunc-ms-mod(ms, 2), 2
        cgk(lsr/2+1, lsr)=cg_coeff(lsr)*0.5e+00_RealK
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE CG_KAPPA_MS
!+ Subroutine to check the number of terms in the phase function.
!
! Purpose:
!   This subroutine checks the prescription of the phase function
!   against the specified options to ensure that information is
!   present to define all required moments.
!
! Method:
!   Straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE check_phf_term(ierr &
        , l_aerosol, n_aerosol, i_aerosol_parametrization &
        , n_aerosol_phf_term &

        , n_phase_term_aerosol_prsc &

        , l_cloud, n_condensed, i_condensed_param, i_phase_cmp &
        , condensed_n_phf &

        , n_phase_term_drop_prsc, n_phase_term_ice_prsc &

        , n_order_phase, l_henyey_greenstein_pf &
        , l_rescale, n_order_forward, l_solar_phf, n_order_phase_solar &
        , nd_aerosol_species, nd_condensed &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE error_pcf
      USE aerosol_parametrization_pcf
      USE cloud_parametrization_pcf
      USE ice_cloud_parametrization_pcf
      USE phase_pcf
!
!
      IMPLICIT NONE
!
!
!
!
!     Dummy arguments:
      INTEGER &
          ierr
!           Error flag
!
!     Dimensions of arrays:
      INTEGER, Intent(IN) :: &
          nd_aerosol_species &
!           Size allocated for species of aerosols
        , nd_condensed
!           Size allocated for condensed components
!
!
!     Generic variables:
      LOGICAL, Intent(IN) :: &
          l_henyey_greenstein_pf &
!           Flag for Henyey-Greenstein phase functions
        , l_rescale &
!           Flag for rescaling of the phase functions
        , l_solar_phf
!           Flag to use a separate treatment of the solar beam
      INTEGER, Intent(IN) :: &
          n_order_phase &
!           Order of terms required in the phase function
        , n_order_forward &
!           Order of the term in the phase function used for rescaling
        , n_order_phase_solar
!           Order of the phase function used in solar calculations
!
!     Aerosol Fields
      LOGICAL, Intent(IN) :: &
          l_aerosol
!           Flag to use aerosols
      INTEGER, Intent(IN) :: &
          n_aerosol &
!           Number of aerosols
        , i_aerosol_parametrization(nd_aerosol_species) &
!           Parametrizations adopted for aerosols
        , n_aerosol_phf_term(nd_aerosol_species) &
!           Number of terms in the phase function

        , n_phase_term_aerosol_prsc(nd_aerosol_species)
!           Number of terms in the prescribed phase functions
!           for each species

!
!     Cloudy Fields
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Flag to include clouds
      INTEGER, Intent(IN) :: &
          n_condensed &
!           Number of condensed components
        , i_condensed_param(nd_condensed) &
!           Parametrizations adopted for condensed components
        , i_phase_cmp(nd_condensed) &
!           Phases of the condensed components
        , condensed_n_phf(nd_condensed) &
!           Number of terms in the phase function

        , n_phase_term_drop_prsc &
!           Number of terms in the prescribed phase functions
!           for each droplets
        , n_phase_term_ice_prsc
!           Number of terms in the prescribed phase functions
!           for each ice crystals

!
!
!     Local variables:
      LOGICAL &
          l_inadequate
!           Flag for inadequate information
      INTEGER &
          j &
!           Loop variable
        , n_order_required
!           Order of terms which are required in the phase function
!
!
!
!     Determine the order of terms for which information in the
!     phase function will be required.
      IF (l_henyey_greenstein_pf) THEN
        n_order_required=1
      ELSE
        IF (l_rescale) THEN
          n_order_required=max(n_order_phase, n_order_forward)
        ELSE
          n_order_required=n_order_phase
        ENDIF
!       If the solar beam is to be treated separately more terms
!       may be required.
        IF (l_solar_phf) THEN
          n_order_required=max(n_order_phase, n_order_phase_solar)
          IF (l_rescale) n_order_required=n_order_required+1
        ENDIF
      ENDIF
!
!     If aerosols are included carry out the required checks.
      IF (l_aerosol) THEN
        l_inadequate=.false.
        DO j=1, n_aerosol
          IF ( (i_aerosol_parametrization(j) == &
                IP_aerosol_param_dry).OR. &
               (i_aerosol_parametrization(j) == &
                IP_aerosol_param_moist) ) THEN
!           In this case information will be extended as a
!           Henyey-Greenstein phase function; and the available
!           information will include the asymmetry.
            continue
          ELSE IF ( (i_aerosol_parametrization(j) == &
                     IP_aerosol_param_phf_dry).OR. &
                    (i_aerosol_parametrization(j) == &
                     IP_aerosol_param_phf_moist) ) THEN
            l_inadequate=(n_order_required > n_aerosol_phf_term(j))

          ELSE IF (i_aerosol_parametrization(j) == &
                 IP_aerosol_unparametrized) THEN
            l_inadequate=(n_order_required > &
                          n_phase_term_aerosol_prsc(j))

          ENDIF
!
          IF (l_inadequate) THEN
            WRITE(iu_err, '(/a, /a, i3, a)') &
              '*** Error: There is not enough information to define' &
              , 'the phase function for aerosol ', j &
              , ' to the desired order.'
            ierr=i_err_fatal
            RETURN
          ENDIF
        ENDDO
      ENDIF
!
      IF (l_cloud) THEN
        l_inadequate=.false.
        DO j=1, n_condensed
          IF (i_phase_cmp(j) == IP_phase_water) THEN
            IF ( (i_condensed_param(j) == IP_slingo_schrecker).OR. &
                 (i_condensed_param(j) == IP_ackerman_stephens).OR. &
                 (i_condensed_param(j) == IP_drop_pade_2) ) THEN
!             The phase function will be extended as a
!             Henyey-Greenstein phase function from information
!             already present.
              continue

            ELSE IF (i_condensed_param(j) == &
                     IP_drop_unparametrized) THEN
              l_inadequate=(n_order_required > n_phase_term_drop_prsc)

            ENDIF
            IF (l_inadequate) THEN
              WRITE(iu_err, '(/a, /a, i3, a, /a)') &
                '*** Error: There is not enough information to define' &
                , 'the phase function for condensed species ', j &
                , ' (water droplets) ', 'to the desired order.'
              ierr=i_err_fatal
              RETURN
            ENDIF
          ELSE IF (i_phase_cmp(j) == IP_phase_ice) THEN
            IF ( (i_condensed_param(j) == IP_slingo_schrecker_ice).OR. &
                 (i_condensed_param(j) == IP_ice_adt).OR. &
                 (i_condensed_param(j) == IP_ice_fu_solar).OR. &
                 (i_condensed_param(j) == IP_ice_fu_ir).OR. &
                 (i_condensed_param(j) == IP_ice_adt_10) ) THEN
!             The phase function will be extended as a
!             Henyey-Greenstein phase function from information
!             already present.
              continue
            ELSE IF ( (i_condensed_param(j) == &
                         IP_slingo_schr_ice_phf).OR. &
                      (i_condensed_param(j) == IP_ice_fu_phf) ) THEN
              l_inadequate=(n_order_required > condensed_n_phf(j))

            ELSE IF (i_condensed_param(j) == &
                     IP_ice_unparametrized) THEN
              l_inadequate=(n_order_required > n_phase_term_ice_prsc)

            ENDIF
            IF (l_inadequate) THEN
              WRITE(iu_err, '(/a, /a, i3, a)') &
                '*** Error: There is not enough information to define' &
                , 'the phase function for condensed species ', j &
                , ' (ice crystals) to the desired order.'
              ierr=i_err_fatal
              RETURN
            ENDIF
          ENDIF
!
        ENDDO
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE CHECK_PHF_TERM
!+ Subroutine to calculate clear-sky fluxes.
!
! Method:
!        This subroutine is called after fluxes including clouds have
!        been calculated to find the corresponding clear-sky fluxes.
!        The optical properties of the column are already known.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE clear_supplement(ierr, n_profile, n_layer &
        , i_solver_clear &
        , trans_free, reflect_free, trans_0_free, source_coeff_free &
        , isolir, flux_inc_direct, flux_inc_down &
        , s_down_free, s_up_free &
        , albedo_surface_diff, albedo_surface_dir &
        , source_ground &
        , l_scale_solar, adjust_solar_ke &
        , flux_direct_clear, flux_total_clear &
        , nd_profile, nd_layer, nd_source_coeff &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE spectral_region_pcf
      USE solver_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_source_coeff
!           Size allocated for layers
!
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , isolir &
!           Spectral region
        , i_solver_clear
!           Solver for clear fluxes
      LOGICAL, Intent(IN) :: &
          l_scale_solar
!           Scaling applied to solar beam
      REAL  (RealK), Intent(IN) :: &
          trans_free(nd_profile, nd_layer) &
!           Transmission coefficients
        , reflect_free(nd_profile, nd_layer) &
!           Reflection coefficients
        , trans_0_free(nd_profile, nd_layer) &
!           Direct transmission coefficients
        , source_coeff_free(nd_profile, nd_layer, nd_source_coeff) &
!           Coefficients in source terms
        , albedo_surface_diff(nd_profile) &
!           Diffuse albedo
        , albedo_surface_dir(nd_profile) &
!           Direct albedo
        , flux_inc_down(nd_profile) &
!           Incident total flux
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , source_ground(nd_profile) &
!           Ground source function
        , adjust_solar_ke(nd_profile, nd_layer)
!           Scaling of solar beam
!
      REAL  (RealK), Intent(INOUT) :: &
          s_down_free(nd_profile, nd_layer) &
!           Downward source
        , s_up_free(nd_profile, nd_layer)
!           Upward source
!
      REAL  (RealK), Intent(OUT) :: &
          flux_direct_clear(nd_profile, 0: nd_layer) &
!           Clear direct flux
        , flux_total_clear(nd_profile, 2*nd_layer+2)
!           Clear total fluxes
!
!
!     Dummy variabales.
      INTEGER &
          n_equation
!           Number of equations
      REAL  (RealK) :: &
          a5(nd_profile, 5, 2*nd_layer+2) &
!           Pentadiagonal matrix
        , b(nd_profile, 2*nd_layer+2) &
!           Rhs of matrix equation
        , work_1(nd_profile, 2*nd_layer+2)
!           Working array for solver
!
!     Subroutines called:
!      EXTERNAL &
!          solar_source, set_matrix_pentadiagonal &
!        , band_solver, solver_homogen_direct
!
!
!
!     The source functions only need to be recalculated in the visible.
      IF (isolir == IP_solar) THEN
        CALL solar_source(n_profile, n_layer &
          , flux_inc_direct &
          , trans_0_free, source_coeff_free &
          , l_scale_solar, adjust_solar_ke &
          , flux_direct_clear &
          , s_down_free, s_up_free &
          , nd_profile, nd_layer, nd_source_coeff &
          )
      ENDIF
!
!
!     Select an appropriate solver for the equations of transfer.
!
      IF (i_solver_clear == IP_solver_pentadiagonal) THEN
!
!       Calculate the elements of the matrix equations.
        CALL set_matrix_pentadiagonal(n_profile, n_layer &
          , trans_free, reflect_free &
          , s_down_free, s_up_free &
          , albedo_surface_diff, albedo_surface_dir &
          , flux_direct_clear(1, n_layer), flux_inc_down &
          , source_ground &
          , a5, b &
          , nd_profile, nd_layer &
          )
        n_equation=2*n_layer+2
!
        CALL band_solver(n_profile, n_equation &
          , 2, 2 &
          , a5, b &
          , flux_total_clear &
          , work_1 &
          , nd_profile, 5, 2*nd_layer+2 &
          )
!
      ELSE IF (i_solver_clear == IP_solver_homogen_direct) THEN
!
!       Solve for the fluxes in the column directly.
        CALL solver_homogen_direct(n_profile, n_layer &
          , trans_free, reflect_free &
          , s_down_free, s_up_free &
          , isolir, albedo_surface_diff, albedo_surface_dir &
          , flux_direct_clear(1, n_layer), flux_inc_down &
          , source_ground &
          , flux_total_clear &
          , nd_profile, nd_layer &
          )
!
      ELSE
!
         WRITE(iu_err, '(/a)') &
            '*** Error: The solver specified for clear-sky fluxes ' &
            //'is not valid.'
         ierr=i_err_fatal
         RETURN
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE CLEAR_SUPPLEMENT
!+ Subroutine to split cloud into maximally overlapped C/S.
!
! Method:
!
!   Convective cloud is left-justified in the grid-box while
!   stratiform cloud is right-justified.
!
! Current owner of code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First version under RCS
!                                               (J. M. Edwards)
!
! Description of code:
!   Fortran 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE cloud_maxcs_split(ierr, n_profile, n_layer, n_cloud_top &
        , w_cloud, frac_cloud &
        , n_cloud_type &
        , n_column_cld, n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
        , nd_profile, nd_layer, id_ct, nd_column, nd_cloud_type)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE error_pcf
      USE def_std_io_icf
      USE cloud_type_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_column &
!           Size allocated for columns at a point
        , nd_cloud_type &
!           Size allocated for columns at a point
        , id_ct
!           Topmost allocated cloudy layer
!
!
!
!     Dummy variables
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_type
!           Number of types of cloud
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Amount of cloud
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!           Fractions of different types of cloud
!
      INTEGER, Intent(OUT) :: &
          n_column_cld(nd_profile) &
!           Number of columns in each profile (including those of
!           zero width)
        , n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(OUT) :: &
          area_column(nd_profile, nd_column)
!           Area of each column
!
!
!     Local variables
      INTEGER &
          l &
!           Loop variable
        , i &
!           Loop variable
        , ii &
!           Loop variable
        , k &
!           Loop variable
        , n_cld_layer &
!           Number of cloudy layers
        , ptr_st &
!           Pointer to stratiform cloud in arrays
        , ptr_cnv &
!           Pointer to convective cloud in arrays
        , key_st(nd_layer+1-id_ct) &
!           Pointers to layers listing left edge of stratiform cloud
!           in increasing order
        , key_cnv(nd_layer+1-id_ct) &
!           Pointers to layers listing right edge of convective cloud
!           in increasing order
        , i_key_cnv &
!           Current pointer to convective cloud
        , i_key_st
!           Current pointer to stratiform cloud
      REAL  (RealK) :: &
          cnv_right(nd_layer+1-id_ct) &
!           Right edges of convective cloud
        , strat_left(nd_layer+1-id_ct) &
!           Left edges of stratiform cloud
        , x_cnv &
!           Right edge of current convective cloud
        , x_st &
!           Left edge of current stratiform cloud
        , x_done &
!           Fraction of the column treated
        , x_new_done &
!           Fraction of the column treated after adding new column
        , dx_col
!           Width of the current column
      REAL  (RealK) :: &
          tol_cloud
!           Tolerance used in neglecting cloudy columns
!
!     Subroutines called:
!      EXTERNAL &
!          shell_sort
!
!
!
!     Set the tolerance used for clouds.
      tol_cloud=1.0e+04_RealK*epsilon(tol_cloud)
!
      IF (n_cloud_type == 2) THEN
        ptr_st=0
        ptr_cnv=0
        DO k=1, n_cloud_type
          IF (k == IP_cloud_type_strat) ptr_st=k
          IF (k == IP_cloud_type_conv) ptr_cnv=k
        ENDDO
        IF ( (ptr_st == 0).OR.(ptr_cnv == 0) ) THEN
          WRITE(iu_err, '(/a)') &
            '*** Error: A type of cloud is missing.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ELSE IF (n_cloud_type == 1) THEN
!       Only stratiform cloud is present.
        ptr_cnv=0
        ptr_st=1
      ELSE
        WRITE(iu_err, '(/a)') &
          '*** Error: There are too many types of cloud for ' &
          //'the type of overlap.'
        ierr=i_err_fatal
        RETURN
      ENDIF
!
!
      n_cld_layer=n_layer+1-n_cloud_top
!     We decompose a column at a time, as this is algorithmically
!     easier, even if not compatible with vectorization.
      DO l=1, n_profile
!
!       Cloud is aligned with convective cloud against the left-hand
!       edge of the grid-box and stratiform cloud to the right. We
!       therefore need to find the right-hand edge of convective
!       cloud and the left-hand edge of stratiform cloud to partition.
        DO i=n_cloud_top, n_layer
          ii=i+1-n_cloud_top
!
          IF (n_cloud_type == 2) THEN
!           Calculate an explicit position for convective cloud if
!           included.
            cnv_right(ii)=w_cloud(l, i)*frac_cloud(l, i, ptr_cnv)
          ELSE
!           In the absence of convective cloud set its width to 0.
            cnv_right(ii)=0.0e+00_RealK
          ENDIF
!
          strat_left(ii)=1.0e+00_RealK-w_cloud(l, i)*frac_cloud(l, i &
            , ptr_st)
!         Initialize the sorting key.
          key_st(ii)=ii
          key_cnv(ii)=ii
        ENDDO
!
!       Find the key ranking these edges in increasing order.
        CALL shell_sort(n_cld_layer, key_cnv, cnv_right)
        CALL shell_sort(n_cld_layer, key_st, strat_left)
!
!
!       Build up the list of notional columns and the list of those
!       where a solution is required.
        n_column_cld(l)=0
        n_column_slv(l)=0
!       Set the changes from a totally clear column to the first
!       actually used.
        DO i=n_cloud_top, n_layer
          ii=i+1-n_cloud_top
          IF (cnv_right(ii) > tol_cloud) THEN
            IF (n_column_cld(l) < nd_column) THEN
              n_column_cld(l)=n_column_cld(l)+1
            ELSE
              WRITE(iu_err, '(/a)') &
                '*** Error: nd_column is too small for the cloud ' &
                //'geometry selected.'
              ierr=i_err_fatal
              RETURN
            ENDIF
            i_clm_lyr_chn(l, n_column_cld(l))=i
            i_clm_cld_typ(l, n_column_cld(l))=ptr_cnv
            area_column(l, n_column_cld(l))=0.0e+00_RealK
          ENDIF
          IF (strat_left(ii) <= tol_cloud) THEN
            IF (n_column_cld(l) < nd_column) THEN
              n_column_cld(l)=n_column_cld(l)+1
            ELSE
              WRITE(iu_err, '(/a)') &
                '*** Error: nd_column is too small for the cloud ' &
                //'geometry selected.'
              ierr=i_err_fatal
              RETURN
            ENDIF
            i_clm_lyr_chn(l, n_column_cld(l))=i
            i_clm_cld_typ(l, n_column_cld(l))=ptr_st
            area_column(l, n_column_cld(l))=0.0e+00_RealK
          ENDIF
        ENDDO
!
!       Now set up the mapping changing the contents of each layer
!       proceeding to the right.
        x_done=0.0e+00_RealK
!       Set the positions of the next convective and stratiform
!       changes, together with their corresponding indices.
        i_key_cnv=1
        x_cnv=cnv_right(key_cnv(1))
        DO while ( (i_key_cnv < n_cld_layer).AND.(x_cnv.lt.tol_cloud) )
          i_key_cnv=i_key_cnv+1
          x_cnv=cnv_right(key_cnv(i_key_cnv))
        ENDDO
        i_key_st=1
        x_st=strat_left(key_st(1))
        DO while ( (i_key_st < n_cld_layer).AND.(x_st.lt.tol_cloud) )
          i_key_st=i_key_st+1
          x_st=strat_left(key_st(i_key_st))
        ENDDO
!
!       Proceed throught the grid-box making the changes.
        DO while (x_done < 1.0e+00_RealK-tol_cloud)
!
          IF (x_cnv <= x_st) THEN
!           The next change involves clearing convective cloud.
            IF (n_column_cld(l) < nd_column) THEN
              n_column_cld(l)=n_column_cld(l)+1
            ELSE
              WRITE(iu_err, '(/a)') &
                '*** Error: nd_column is too small for the cloud ' &
                //'geometry selected.'
              ierr=i_err_fatal
              RETURN
            ENDIF
            i_clm_lyr_chn(l, n_column_cld(l))=key_cnv(i_key_cnv) &
              +n_cloud_top-1
            i_clm_cld_typ(l, n_column_cld(l))=0
            x_new_done=x_cnv
            i_key_cnv=i_key_cnv+1
            IF (i_key_cnv <= n_cld_layer) THEN
              x_cnv=cnv_right(key_cnv(i_key_cnv))
            ELSE
!             There are no further changes to convective cloud
!             right of this.
              x_cnv=1.0e+00_RealK
            ENDIF
          ELSE IF (x_cnv > x_st) THEN
!           The next change involves introducing stratiform cloud.
            IF (n_column_cld(l) < nd_column) THEN
              n_column_cld(l)=n_column_cld(l)+1
            ELSE
              WRITE(iu_err, '(/a)') &
                '*** Error: nd_column is too small for the cloud ' &
                //'geometry selected.'
              ierr=i_err_fatal
              RETURN
            ENDIF
            i_clm_lyr_chn(l, n_column_cld(l))=key_st(i_key_st) &
              +n_cloud_top-1
            i_clm_cld_typ(l, n_column_cld(l))=ptr_st
            x_new_done=x_st
            i_key_st=i_key_st+1
            IF (i_key_st <= n_cld_layer) THEN
              x_st=strat_left(key_st(i_key_st))
            ELSE
!             There are no further changes to stratiform cloud
!             right of this.
              x_st=1.0e+00_RealK
            ENDIF
          ENDIF
!
!         If both convective and stratiform right markers have
!         reached 1 we have a closing column.
          IF ( (x_st > 1.0e+00_RealK-tol_cloud).AND. &
               (x_cnv > 1.0e+00_RealK-tol_cloud) ) &
            x_new_done=1.0e+00
!
!         If this new column is wide enough we solve within it.
          dx_col=x_new_done-x_done
          IF (dx_col > tol_cloud) THEN
            n_column_slv(l)=n_column_slv(l)+1
            list_column_slv(l, n_column_slv(l))=n_column_cld(l)
            area_column(l, n_column_cld(l))=dx_col
            x_done=x_new_done
          ELSE
            area_column(l, n_column_cld(l))=0.0e+00_RealK
          ENDIF
!
        ENDDO
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE CLOUD_MAXCS_SPLIT
!+ Subroutine to set clear-sky optical properties.
!
! Method:
!        The arrays of clear-sky optical properties at the top
!       of the column and of total optical properties lower
!       down are combined to give a sinle array of clear-sky
!       optical properties.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE copy_clr_full(n_profile, n_layer, n_cloud_top &
        , n_order_phase &
        , tau_clr, omega_clr, phase_fnc_clr &
        , tau, omega, phase_fnc &
        , tau_clr_f, omega_clr_f, phase_fnc_clr_f &
!                       Sizes of arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_max_order &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , nd_layer_clr &
!           Size allocated for totally clear layers
        , id_ct &
!           Topmost declared layer for cloudy optical properties
        , nd_max_order
!           Size allowed for orders of spherical harmonics
!
!                        Atmospheric properties
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Topmost cloudy layer
        , n_order_phase
!           Number of terms in the phase function
!
!                        Optical properties
      REAL  (RealK), Intent(IN) :: &
          tau_clr(nd_profile, nd_layer_clr) &
!           Optical depth in totally clear region
        , omega_clr(nd_profile, nd_layer_clr) &
!           Single scattering albedo in totally clear region
        , phase_fnc_clr(nd_profile, nd_layer_clr, nd_max_order)
!           Phase function in totally clear region
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, id_ct: nd_layer) &
!           Optical depth restricted to clear-sky regions
        , omega(nd_profile, id_ct: nd_layer) &
!           ALbedo of single scattering restricted to clear-sky regions
        , phase_fnc(nd_profile, id_ct: nd_layer, nd_max_order)
!           Phase function restricted to clear-sky regions
!
!                        Single scattering properties
      REAL  (RealK), Intent(OUT) :: &
          tau_clr_f(nd_profile, nd_layer) &
!           Optical depth
        , omega_clr_f(nd_profile, nd_layer) &
!           Single scattering albedo
        , phase_fnc_clr_f(nd_profile, nd_layer, nd_max_order)
!           Phase function
!
!
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i &
!           Loop variable
        , k
!           Loop variable
!
!
!
!     Above cloud top.
!      DO i=1, n_cloud_top-1
!        DO l=1, n_profile
!          tau_clr_f(l, i)=tau_clr(l, i)
!          omega_clr_f(l, i)=omega_clr(l, i)
!          phase_fnc_clr_f(l, i, 1)=phase_fnc_clr(l, i, 1)
!        ENDDO
!        DO k=2, n_order_phase
!          DO l=1, n_profile
!            phase_fnc_clr_f(l, i, k)=phase_fnc_clr(l, i, k)
!          ENDDO
!        ENDDO
!      ENDDO
!
!     Below cloud top.
      DO i=1, nd_layer
        DO l=1, nd_profile
          tau_clr_f(l, i)=tau(l, i)
          omega_clr_f(l, i)=omega(l, i)
          phase_fnc_clr_f(l, i, 1)=phase_fnc(l, i, 1)
        ENDDO
      ENDDO
      DO k=2, n_order_phase
        DO i=1, nd_layer
          DO l=1, nd_profile
            phase_fnc_clr_f(l, i, k)=phase_fnc(l, i, k)
          ENDDO
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE COPY_CLR_FULL
!+ Subroutine to set clear-sky solar phase function.
!
! Method:
!        The arrays of clear-sky forward scattering and the solar
!       phase function at the top of the column and of these
!       same properties from the total list lower down
!       are combined to give unified arrays of clear-sky
!       optical properties.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE copy_clr_sol(n_profile, n_layer, n_cloud_top &
        , n_direction, l_rescale &
        , forward_scatter_clr, phase_fnc_solar_clr &
        , forward_scatter, phase_fnc_solar &
        , forward_scatter_clr_f &
        , phase_fnc_solar_clr_f &
!                       Sizes of arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_direction &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , nd_layer_clr &
!           Size allocated for totally clear layers
        , id_ct &
!           Topmost declared layer for cloudy optical properties
        , nd_direction
!           SIze allocated for viewing directions
!
!                        Atmospheric properties
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of atmospheric layers
        , n_cloud_top &
!           Topmost cloudy layer
        , n_direction
!           Number of terms in the phase function
      LOGICAL, Intent(IN) :: &
          l_rescale
!           Flag for rescaling of the optical properties
!
!                        Optical properties
      REAL  (RealK), Intent(IN) :: &
          forward_scatter_clr(nd_profile, nd_layer_clr) &
!           Forward scattering in the totally clear region
        , phase_fnc_solar_clr(nd_profile, nd_layer_clr, nd_direction)
!           Phase function in totally clear region
      REAL  (RealK), Intent(IN) :: &
          forward_scatter(nd_profile, id_ct: nd_layer) &
!           Forward scattering in the cloudy regions
        , phase_fnc_solar(nd_profile, id_ct: nd_layer, nd_direction)
!           Phase function restricted to clear-sky regions
!
!                        Single scattering properties
      REAL  (RealK), Intent(OUT) :: &
          forward_scatter_clr_f(nd_profile, nd_layer) &
!           Forward scattering expanded to the whole column
        , phase_fnc_solar_clr_f(nd_profile, nd_layer, nd_direction)
!           Phase function expanded to the whole column
!
!
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i &
!           Loop variable
        , k
!           Loop variable
!
!
!
!     Above cloud top.
      DO i=1, n_cloud_top-1
        IF (l_rescale) THEN
          DO l=1, n_profile
            forward_scatter_clr_f(l, i)=forward_scatter_clr(l, i)
          ENDDO
        ENDIF
        DO k=1, n_direction
          DO l=1, n_profile
            phase_fnc_solar_clr_f(l, i, k)=phase_fnc_solar_clr(l, i, k)
          ENDDO
        ENDDO
      ENDDO
!
!     Below cloud top.
      DO i=n_cloud_top, n_layer
        IF (l_rescale) THEN
          DO l=1, n_profile
            forward_scatter_clr_f(l, i)=forward_scatter(l, i)
          ENDDO
        ENDIF
        DO k=1, n_direction
          DO l=1, n_profile
            phase_fnc_solar_clr_f(l, i, k)=phase_fnc_solar(l, i, k)
          ENDDO
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE COPY_CLR_SOL
!+ Subroutine to calculate basis functions for the diffuse albedo.
!
! Purpose:
!   This routine takes the BRDF supplied and calculates a diffuse
!   albedo for isotropic radiation, which is used to define an
!   equivalent extinction.
!
! Method:
!   As this routine is called only once speed is not too critical
!   so direct calculation is used. See calc_brdf.f for a note on
!   the symmetries of the BRDF and storage.
!
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE diff_albedo_basis(n_brdf_basis_fnc &
        , ls_brdf_trunc, f_brdf &
        , uplm_zero &
        , diffuse_alb_basis &
        , nd_brdf_basis_fnc, nd_brdf_trunc, nd_sph_coeff &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_brdf_basis_fnc &
!           Size allocated for BRDF basis functions
        , nd_brdf_trunc &
!           Size allocated for truncation of BRDFs
        , nd_sph_coeff
!           Size allocated for spherical coefficients (dimensioning
!           as ND_BRDF_TRUNC+1 might seem natural, but this can
!           lead to problems at low orders of truncation if
!           ND_BRDF_TRUNC is set too large higher in the program.
!
!
!
!     Dummy arguments.
      REAL  (RealK), Intent(IN) :: &
          uplm_zero(nd_sph_coeff)
!           Array of Upsilon_l^m and derivatives at polar angles of pi/2
      INTEGER, Intent(IN) :: &
          n_brdf_basis_fnc &
!           Number of basis functions for BRDFs
        , ls_brdf_trunc
!           Order of truncation applied to BRDFs
      REAL  (RealK), Intent(IN) :: &
          f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc)
!           Array of moments of BRDF basis functions
!
      REAL  (RealK), Intent(OUT) :: &
          diffuse_alb_basis(nd_brdf_basis_fnc)
!           The diffuse albedo for isotropic radiation calculated
!           from the appropriate BRDF basis function
!
!
!     Local variables
      INTEGER &
          lsr &
!           Reduced polar order of harmonic
        , lsr_p &
!           Reduced polar order of harmonic
        , j
!           Loop variable
!
      REAL  (RealK) :: &
          factor(nd_brdf_trunc+1) &
!           Term involving a sum over l'' calculated for speed.
        , sum_p(nd_brdf_trunc+1)
!           Sum of products of the BRDF and factors over l''
!
!
!
!
      DO j=1, n_brdf_basis_fnc
        diffuse_alb_basis(j)=0.0e+00_RealK
!
        DO lsr_p=1, ls_brdf_trunc+1, 2
          factor(lsr_p)=uplm_zero(lsr_p) &
            *real(1-2*mod(lsr_p-1, 2), RealK) &
            /real((lsr_p-2)*(lsr_p+1), RealK)
        ENDDO
!
        DO lsr=1, ls_brdf_trunc+1, 2
          sum_p(lsr)=0.0e+00_RealK
          DO lsr_p=1, ls_brdf_trunc+1, 2
            sum_p(lsr)=sum_p(lsr)+factor(lsr_p) &
              *f_brdf(j, (lsr-1)/2, (lsr_p-1)/2, 0)
          ENDDO
          diffuse_alb_basis(j)=diffuse_alb_basis(j) &
            +sum_p(lsr)*uplm_zero(lsr) &
            /real((lsr-2)*(lsr+1), RealK)
        ENDDO
!
        diffuse_alb_basis(j)=diffuse_alb_basis(j)*4.0e+00_RealK*pi
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE DIFF_ALBEDO_BASIS
!+ Subroutine to calculate differences in source functions.
!
! Method:
!        Using the polynomial fit to the Planck function, values
!        of this function at the boundaries of layers are found
!        and differences across layers are determined. If the
!        Planckian is being taken to vary quadratically across
!        the layer second differences are found.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE diff_planck_source(n_profile, n_layer &
        , n_deg_fit, thermal_coefficient &
        , t_ref_planck, t_level, t_ground &
        , planck_flux, diff_planck, planck_ground &
        , l_ir_source_quad, t, diff_planck_2 &
        , i_angular_integration &
        , n_viewing_level, i_rad_layer, frac_rad_layer &
        , planck_radiance &
        , l_tile, n_point_tile, n_tile, list_tile &
        , frac_tile, t_tile, planck_flux_tile &
        , nd_profile, nd_layer, nd_thermal_coeff &
        , nd_radiance_profile, nd_viewing_level &
        , nd_point_tile, nd_tile &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE angular_integration_pcf
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_thermal_coeff &
!           Size allocated for thermal coefficients
        , nd_radiance_profile &
!           Size allocated for profiles where radiances are calculated
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_point_tile &
!           Size allocated for points with surface tiling
        , nd_tile
!           Size allocated for the number of tiles
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_deg_fit
!           Degree of fitting function
!
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which to intercept radiances
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
      INTEGER, Intent(IN) :: &
          i_angular_integration
!           Type of angular integration
!
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic IR-source
      REAL  (RealK), Intent(IN) :: &
          thermal_coefficient(0: nd_thermal_coeff-1) &
!           Coefficients of fit to the Planckian flux function
        , t_ref_planck &
!           Planckian reference temperature
        , t_level(nd_profile, 0: nd_layer) &
!           Temperatures on levels
        , t(nd_profile, nd_layer) &
!           Temperatures at centres of layers
        , t_ground(nd_profile)
!           Temperatures at ground
!
!     Tiling of the surface:
      LOGICAL, Intent(IN) :: &
          l_tile
!           Local to allow tiling options
      INTEGER, Intent(IN) :: &
          n_point_tile &
!           Number of points to tile
        , n_tile &
!           Number of tiles used
        , list_tile(nd_point_tile)
!           List of points with surface tiling
      REAL  (RealK), Intent(IN) :: &
          frac_tile(nd_point_tile, nd_tile) &
!           Fraction of tiled grid-points occupied by each tile
        , t_tile(nd_point_tile, nd_tile)
!           Local surface temperatures on individual tiles
!
      REAL  (RealK), Intent(OUT) :: &
          planck_flux(nd_profile, 0: nd_layer) &
!           Planckian flux on levels
        , diff_planck(nd_profile, nd_layer) &
!           Differences in Planckian flux (bottom-top)
        , diff_planck_2(nd_profile, nd_layer) &
!           Twice 2nd differences in the Planckian flux
        , planck_ground(nd_profile) &
!           Planckian flux at the surface temperature
        , planck_radiance(nd_radiance_profile, nd_viewing_level) &
!           Planckian radiances at viewing levels
        , planck_flux_tile(nd_point_tile, nd_tile)
!           Local Planckian fluxes on surface tiles
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          t_ratio(nd_profile) &
        , t_ratio2(nd_profile, 0: nd_layer) 
!           Temperature ratio
!
!
!
      IF (i_angular_integration == IP_spherical_harmonic) THEN
!
!       Calculate the Planckian radiance on viewing levels.
        DO i=1, n_viewing_level
          DO l=1, n_profile
!           Interpolate linearly in the temperature.
            t_ratio(l)=(t_level(l, i_rad_layer(i)-1) &
              +(t_level(l, i_rad_layer(i))-t_level(l, i_rad_layer(i)-1)) &
              *frac_rad_layer(i))/t_ref_planck
!           Use the second differences of the Planckian as temporary
!           storage.
            planck_radiance(l, i) &
              =thermal_coefficient(n_deg_fit)
          ENDDO
          DO j=n_deg_fit-1, 0, -1
            DO l=1, n_profile
              planck_radiance(l, i) &
                =planck_radiance(l, i) &
                *t_ratio(l)+thermal_coefficient(j)
            ENDDO
          ENDDO
!
          DO l=1, n_profile
            planck_radiance(l, i)=planck_radiance(l, i)/pi
          ENDDO
!
        ENDDO
!
      ENDIF
!
!
!     Calculate the change in the Planckian flux across each layer.
!hmjb VECTORIZED LOOPS FOLLOW BELOW
!hmjb      DO l=1, n_profile
!hmjb        t_ratio(l)=t_level(l, 0)/t_ref_planck
!hmjb        planck_flux(l, 0) &
!hmjb          =thermal_coefficient(n_deg_fit)
!hmjb      ENDDO
!hmjb      DO j=n_deg_fit-1, 0, -1
!hmjb        DO l=1, n_profile
!hmjb          planck_flux(l, 0) &
!hmjb            =planck_flux(l, 0) &
!hmjb            *t_ratio(l)+thermal_coefficient(j)
!hmjb        ENDDO
!hmjb      ENDDO
!hmjb      DO i=1, n_layer
!hmjb        DO l=1, n_profile
!hmjb          t_ratio(l)=t_level(l, i)/t_ref_planck
!hmjb          planck_flux(l, i) &
!hmjb            =thermal_coefficient(n_deg_fit)
!hmjb        ENDDO
!hmjb        DO j=n_deg_fit-1, 0, -1
!hmjb          DO l=1, n_profile
!hmjb            planck_flux(l, i) &
!hmjb              =planck_flux(l, i) &
!hmjb              *t_ratio(l)+thermal_coefficient(j)
!hmjb          ENDDO
!hmjb        ENDDO
!hmjb        DO l=1, n_profile
!hmjb          diff_planck(l, i)=planck_flux(l, i) &
!hmjb            -planck_flux(l, i-1)
!hmjb        ENDDO
!hmjb      ENDDO

!CDIR COLLAPSE
      DO i=0, nd_layer
        DO l=1, nd_profile
           t_ratio2(l, i)=t_level(l, i)/t_ref_planck
        ENDDO
      ENDDO
!CDIR COLLAPSE
      DO i=0, nd_layer
        DO l=1, nd_profile
          planck_flux(l, i) &
            =thermal_coefficient(n_deg_fit)
        ENDDO 
      ENDDO
!CDIR COLLAPSE
      DO j=n_deg_fit-1, 0, -1
        DO i=0, nd_layer
          DO l=1, nD_profile
            planck_flux(l, i) &
              =planck_flux(l, i) &
              *t_ratio2(l, i)+thermal_coefficient(j)
          ENDDO
        ENDDO
      ENDDO
!CDIR COLLAPSE
      DO i=1, nd_layer
        DO l=1, nd_profile
          diff_planck(l, i)=planck_flux(l, i) &
            -planck_flux(l, i-1)
        ENDDO
      ENDDO
!
!
!     Calculate the second difference if required.
      IF (l_ir_source_quad) THEN
!hmjb VECTORIZED LOOPS FOLLOW BELOW
!hmjb        DO i=1, n_layer
!hmjb!         Use the second difference for temporary storage.
!hmjb!         of the Planckian at the middle of the layer.
!hmjb          DO l=1, n_profile
!hmjb            t_ratio(l)=t(l, i)/t_ref_planck
!hmjb            diff_planck_2(l, i) &
!hmjb              =thermal_coefficient(n_deg_fit)
!hmjb          ENDDO
!hmjb          DO j=n_deg_fit-1, 0, -1
!hmjb            DO l=1, n_profile
!hmjb              diff_planck_2(l, i) &
!hmjb                =diff_planck_2(l, i) &
!hmjb                *t_ratio(l)+thermal_coefficient(j)
!hmjb            ENDDO
!hmjb          ENDDO
!hmjb          DO l=1, n_profile
!hmjb            diff_planck_2(l, i)=2.0e+00_RealK*(planck_flux(l, i) &
!hmjb              +planck_flux(l, i-1)-2.0e+00_RealK*diff_planck_2(l, i))
!hmjb          ENDDO
!hmjb        ENDDO

!         Use the second difference for temporary storage.
!         of the Planckian at the middle of the layer.
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            t_ratio2(l, i)=t(l, i)/t_ref_planck
            diff_planck_2(l, i) &
              =thermal_coefficient(n_deg_fit)
          ENDDO
        ENDDO
!CDIR COLLAPSE
        DO j=n_deg_fit-1, 0, -1
          DO i=1, nd_layer
            DO l=1, nd_profile
              diff_planck_2(l, i) &
                =diff_planck_2(l, i) &
                *t_ratio2(l, i)+thermal_coefficient(j)
            ENDDO
          ENDDO
        ENDDO
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            diff_planck_2(l, i)=2.0e+00_RealK*(planck_flux(l, i) &
              +planck_flux(l, i-1)-2.0e+00_RealK*diff_planck_2(l, i))
          ENDDO
        ENDDO
      ENDIF
!
!
!     Planckian flux at the surface.
      DO l=1, n_profile
        t_ratio(l)=t_ground(l)/t_ref_planck
        planck_ground(l)=thermal_coefficient(n_deg_fit)
      ENDDO
      DO j=n_deg_fit-1, 0, -1
        DO l=1, n_profile
          planck_ground(l)=planck_ground(l)*t_ratio(l) &
            +thermal_coefficient(j)
        ENDDO
      ENDDO
!
!     Local Planckian fluxes will be required on tiled surfaces.
!     Furthermore, the overall Planckian will be calculated as a
!     weighted sum of the individual components: this allows for
!     variations in the Planckian between spectral bands more
!     satisfactorily than the use of an equivalent temperature
!     can.
      IF (l_tile) THEN
!
        DO k=1, n_tile
          DO l=1, n_point_tile
            t_ratio(l)=t_tile(l, k)/t_ref_planck
            planck_flux_tile(l, k)=thermal_coefficient(n_deg_fit)
          ENDDO
          DO j=n_deg_fit-1, 0, -1
            DO l=1, n_point_tile
              planck_flux_tile(l, k)=planck_flux_tile(l, k)*t_ratio(l) &
                +thermal_coefficient(j)
            ENDDO
          ENDDO
        ENDDO
!
        DO l=1, n_point_tile
          planck_ground(list_tile(l)) &
            =frac_tile(l, 1)*planck_flux_tile(l, 1)
        ENDDO
        DO k=2, n_tile
          DO l=1, n_point_tile
            planck_ground(list_tile(l))=planck_ground(list_tile(l)) &
              +frac_tile(l, k)*planck_flux_tile(l, k)
          ENDDO
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE DIFF_PLANCK_SOURCE
!+ Subroutine to find the eigenvalues of a symmetric tridiagonal matrix.
!
! Purpose:
!   To caulate the eigenvalues of a symmetric tridiagonal matrix.
!
! Method:
!   The standard QR-algorithm with shifts is used, though this routine
!   is not a fully general implementation. The algorithm is based on the
!   pseudo-code and description given in "Numerical Analysis" by
!   R. L. Burden and D. J. Faires (PWS-Kent 1989).
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE eigenvalue_tri(n_matrix, n_in, d, e &
         , tol, n_max_iteration &
         , nd_matrix)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
!
!
      IMPLICIT NONE
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
         nd_matrix
!          Size allocated for matrices treated together.
!
!
!     Dummy arguments
!
      INTEGER, Intent(IN) :: &
         n_matrix &
!          Number of matrices treated together
       , n_in &
!          Order of input matrix
       , n_max_iteration
!          Maximum number of iterations
!
      REAL  (RealK), Intent(IN) :: &
         tol
!          Tolerance for setting the subdiagonal elements to 0.
!
      REAL  (RealK), Intent(INOUT) :: &
         d(nd_matrix, n_in) &
!          Main diagonal of the matrix: this will hold the eigenvalues
!          on output.
       , e(nd_matrix, n_in)
!          Subdiagonal of the matrix: E(1) is not used. E is reduced
!          to below the tolerance by the routine.
!
!
!     Local Variables:
!
      INTEGER &
         n &
!          Current working size of the problem
       , l &
!          Loop variable
       , j &
!          Loop variable
       , iteration
!          Current iteration
      REAL  (RealK) :: &
         shift(n_matrix) &
!          Accumulated `shift''
       , d_shift(n_matrix) &
!          Increment in `shift''
       , b &
!          Temporary variable used in solving quadratic
       , c &
!          Temporary variable used in solving quadratic
       , discr &
!          Discriminant used in solving quadratic
       , kappa_1 &
!          First root of quadratic
       , kappa_2
!          Second root of quadratic
      REAL  (RealK) :: &
         abs_e &
!          Maximum absolute value of diagonal elements of the
!          current rows of the matrices
       , sinr(n_matrix) &
!          Sine of current rotation
       , cosr(n_matrix) &
!          Cosine of current rotations
       , cosr_temp &
!          Temporary cosine
       , sq &
!          Temporary square root
       , sup_diag(n_matrix) &
!          Element of first superdiagonal of matrix on the J-1st row
       , sup_diag_old(n_matrix)
!          Previous value of SUP_DIAG
!
!
!
!     The algorithm proceeds iteratively. The matrix supplied, A, is
!     decomposed as A=QR where Q is orthogonal and R is upper
!     triangular. A''=RQ is then formed and the process is repeated with
!     A''. This leads to a sequence of matrices which converge to one
!     with the eigenvalues down the diagonal.
!
!     Initialization:
!     Reduce the working size of the matrix if the off-diagonal
!     elements are small enough.
      n=n_in
      abs_e=0.0e+00_RealK
      DO l=1, n_matrix
        abs_e=max(abs_e, abs(e(l, n)))
      ENDDO
      DO while ( (n > 1).AND.(abs_e < tol) )
        n=n-1
        DO l=1, n_matrix
          abs_e=max(abs_e, abs(e(l, n)))
        ENDDO
      ENDDO
!
      iteration=0
      DO l=1, n_matrix
        shift(l)=0.0e+00_RealK
      ENDDO
!
!
      DO while ( (n > 1).AND.(iteration < n_max_iteration) )
!
!
        iteration=iteration+1
!
!       Form an estimate of the first eigenvalue to be found by
!       finding the eigenvalues of the 2x2 matrix at the bottom
!       right-hand corner.
        DO l=1, n_matrix
          b=d(l, n-1)+d(l, n)
          c=d(l, n-1)*d(l, n)-e(l, n)*e(l, n)
          discr=sqrt(b*b-4.0e+00_RealK*c)
!         For reasons of conditioning we calculate the root of largest
!         magnitude and determine the other from the product of the
!         roots.
          kappa_1=0.5e+00_RealK*(b+sign(discr, b))
          kappa_2=c/kappa_1
!
!         Calculate the `shift'' so as to accelerate convergence to the
!         last eigenvalue. A simple two-branch IF-test should be
!         amenable to vectorization if the vector CPU has a vector
!         mask register.
          IF ( abs(kappa_1-d(l, n)) < &
               abs(kappa_2-d(l, n)) ) THEN
            d_shift(l)=kappa_1
          ELSE
            d_shift(l)=kappa_2
          ENDIF
          shift(l)=shift(l)+d_shift(l)
        ENDDO
!
!       Shift the diagonal elements.
        DO j=1, n
          DO l=1, n_matrix
            d(l, j)=d(l, j)-d_shift(l)
          ENDDO
        ENDDO
!
!
!       Form the QR-decompostion of the matrix by constructing
!       rotations to eliminate the sub-diagonal elements. COSR(J)
!       and SINR(J) are the cosine and sine of the rotations to
!       eliminate the element (J, J-1) of the input matrix: these
!       values specify the transpose of Q as we really construct
!       R=Qt.A by this procedure. The upper triangular matrix, R,
!       has two superdiagonals, but in practice only the first
!       is required. As the resulting matrix, RQ, will be a
!       symmetric tridaigonal matrix only its diagonal, D, and
!       the sub-diagonal, E, need be formed.
!
!       Inintialize:
        DO l=1, n_matrix
          sup_diag(l)=e(l, 2)
          cosr(l)=1.0e+00_RealK
          sinr(l)=0.0e+00_RealK
        ENDDO
!
        DO j=2, n
!
          DO l=1, n_matrix
!
!           This block of code is a little opaque as the variables
!           SINR and COSR are re-used to avoid the need to declare
!           them explicitly as vectors. We form the rotation to
!           elminate E(J) and also calculate E(J-1) of the new matrix
!           RQ using SINR(J-1) for the last time. The new cosine of
!           the rotation must be stored because we still need
!           the old one.
            sq=sqrt(d(l, j-1)*d(l, j-1)+e(l, j)*e(l, j))
            e(l, j-1)=sinr(l)*sq
            sinr(l)=e(l, j)/sq
            cosr_temp=d(l, j-1)/sq
!
!           Adjust the superdiagonal of the previous row of the matrix
!           as required by the elimination. The calculation of D(J-1)
!           actually belongs to the formation of RQ, but is done here
!           before we overwrite COSR.
            sup_diag_old(l)=sup_diag(l)
            sup_diag(l)=cosr_temp*sup_diag(l)+sinr(l)*d(l, j)
            d(l, j-1)=cosr(l)*d(l, j-1)+sinr(l)*sup_diag(l)
            cosr(l)=cosr_temp
!
!           Adjustments to the current row:
            d(l, j)=-sinr(l)*sup_diag_old(l)+cosr(l)*d(l, j)
            IF (j < n) sup_diag(l)=cosr(l)*e(l, j+1)
!
          ENDDO
!
        ENDDO
!
        DO l=1, n_matrix
          e(l, n)=sinr(l)*d(l, n)
          d(l, n)=cosr(l)*d(l, n)
        ENDDO
!
!
!       Test for convergence and `shift'' the converged eigenvalues.
!       back to their true values.
        abs_e=0.0e+00_RealK
        DO l=1, n_matrix
          abs_e=max(abs_e, abs(e(l, n)))
        ENDDO
        DO while ( (n > 1).AND.(abs_e < tol) )
          DO l=1, n_matrix
            d(l, n)=d(l, n)+shift(l)
          ENDDO
          n=n-1
          DO l=1, n_matrix
            abs_e=max(abs_e, abs(e(l, n)))
          ENDDO
        ENDDO
!
!
      ENDDO
!
!
!     Check that convergence has occurred.
      IF (n > 1) THEN
        WRITE(iu_err, '(/a)') &
          '*** Warning: Convergence has not occurred while ' &
          //'calculating eigenvalues.' &
          , 'the calculation continues.'
      ELSE
!       Shift the first eigenvalue back to its true value.
        DO l=1, n_matrix
          d(l, 1)=d(l, 1)+shift(l)
        ENDDO
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE EIGENVALUE_TRI
!+ Subroutine to set up and solve the eigensystem.
!
! Purpose:
!   For a given value of the azimuthal quantum number, MS, this
!   routine returns the positive eigenvalues imposed by the trunctaion
!   in one layer and the corresponsing eigenvectors.
!
! Method:
!   The sub-diagonal of the full matrix is calculated and then reduced
!   to the diagonal and subdiagonal of the reduced matrix. The
!   eigenvalues are then found by calling the QR-algorithm and the
!   eigenvectors are obtained from a recurrence relation.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE eig_sys(n_profile, ls_trunc, ms, n_red_eigensystem &
        , cg_coeff, sqs &
        , mu, eig_vec &
        , nd_profile, nd_red_eigensystem, nd_max_order &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE sph_qr_iter_acf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_red_eigensystem &
!           Size allocated for the reduced eigensystem
        , nd_max_order
!           Size allocated for the order of the calculation
!
!
!     Dummy variables
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric profiles
        , ls_trunc &
!           Order of L for truncation
        , ms &
!           Azimuthal quantum number
        , n_red_eigensystem
!           Size of the reduced eigenproblem
      REAL  (RealK), Intent(IN) :: &
          cg_coeff(ls_trunc+1-ms) &
!           Clebsch-Gordan coefficients
        , sqs(nd_profile, 0: nd_max_order)
!           Square roots of S-coefficients
      REAL  (RealK), Intent(OUT) :: &
          mu(nd_profile, nd_red_eigensystem) &
!           Eigenvalues
        , eig_vec(nd_profile, 2*nd_red_eigensystem, nd_red_eigensystem)
!           Eigenvectors
!
!
!     Local variables
      INTEGER &
          j &
!           Loop variable
        , k &
!           Loop variable
        , l &
!           Loop variable
        , ls &
!           Order of spherical harmonic
        , n_max_qr_iteration
!           Maximum number of QR iterations
      REAL  (RealK) :: &
          tol &
!           Tolerance for assessing convergence of the QR-algorithm
        , ec(nd_profile, 2*n_red_eigensystem) &
!           Sub-diagonal of full matrix
        , e(nd_profile, n_red_eigensystem) &
!           Sub-diagonal of reduced matrix
        , normalization(nd_profile) &
!           Normalization factor for the eigenvector
        , c_ratio(nd_profile) &
!           Common ratio in the geometric progression used to rescale
!           the recurrence relation to avoid overflows
        , rescale(nd_profile)
!           Multiplier to convert the terms of the scaled recurrence
!           to the the final quantities
!
!
!
!     Set the tolerance for convergence of the algorithm from the
!     precision of the machine.
      tol=rp_tol_factor_sph_qr*epsilon(rp_tol_factor_sph_qr)
!
!     Calculate the reduced matrix to yield the eigenvalues. EC_...
!     represent elements of the sub-diagonal of the full matrix:
!     D and E are the diagonal and sub-diagonal of the reduced matrix.
!
!
!     Calculate the sub-diagonal of the full matrix.
      DO j=2, ls_trunc+1-ms
        ls=ms-1+j
        DO l=1, n_profile
          ec(l, j)=cg_coeff(j-1)/(sqs(l, ls)*sqs(l, ls-1))
        ENDDO
      ENDDO
!
!     Retain odd rows and columns of the square of the preceeding
!     matrix. The diagonal terms are stored in MU as this will be
!     reduced to the eigenvalues later.
      DO l=1, n_profile
        mu(l, 1)=ec(l, 2)**2
      ENDDO
      DO j=2, n_red_eigensystem
        DO l=1, n_profile
          mu(l, j)=ec(l, 2*j-1)**2+ec(l, 2*j)**2
          e(l, j)=ec(l, 2*j-2)*ec(l, 2*j-1)
        ENDDO
      ENDDO
!
!     Determine the eigenvalues of the reduced matrix, which
!     are the squares of the (positive) eigenvalues of the
!     full matrix. If the eigensystem is of size 1 no calculation
!     is required.
      IF (n_red_eigensystem > 1) THEN
!       The number of iterations required for convergence increases
!       as the order of truncation rises. A small allowance is made
!       for extra iterations.
        n_max_qr_iteration=ls_trunc+25
        CALL eigenvalue_tri(n_profile, n_red_eigensystem &
          , mu, e, tol, n_max_qr_iteration &
          , nd_profile &
          )
      ENDIF
      DO k=1, n_red_eigensystem
        DO l=1, n_profile
          mu(l, k)=sqrt(mu(l, k))
          IF (mu(l, k) > 1.0e+00_RealK) THEN
            c_ratio(l)=5.0e-01_RealK/mu(l, k)
          ELSE
            c_ratio(l)=1.0e+00_RealK
          ENDIF
        ENDDO
!
!       Use the recurrence relation to find the eigenvectors of the
!       full matrix. For large values of MU there will be an
!       eigenvector like MU^J and one like MU^-J. The latter (minimal)
!       solution is required, but for |MU|>1 the recurrence is
!       unstable, so the growing solution will will swamp the required
!       solution. Conversely, with downward recurrence, the desired
!       solution grows and will dominate in the recurrence. When
!       |MU|<1 the recurrence is stable in either direction so downward
!       recurrence is used consistently. On further complication must
!       be taken into account: if MU is very large (as can happen with
!       almost conservative scattering) the elements of the eigenvector
!       may be of so large a range of magnitudes that the recurrence
!       overflows. A scaling factor, c, is therefore introduced so that
!       the j''th element of the eigenvector, e_j=c^j.e_j'. s may not
!       be less than 1 for small eigenvalues or the same problem will
!       be introduced with them; the vector e'' has elements of order 1.
!
        j=2*n_red_eigensystem
        DO l=1, n_profile
          eig_vec(l, j, k)=1.0e+00_RealK
        ENDDO
        j=j-1
        DO l=1, n_profile
          eig_vec(l, j, k)=c_ratio(l)*mu(l, k)/ec(l, j+1)
        ENDDO
        DO while(j > 1)
          j=j-1
          DO l=1, n_profile
            eig_vec(l, j, k) &
              =(mu(l, k)*eig_vec(l, j+1, k) &
              -c_ratio(l)*ec(l, j+2)*eig_vec(l, j+2, k)) &
              *c_ratio(l)/ec(l, j+1)
          ENDDO
        ENDDO
!
!       Remove the scaling factor, renormalize the eigenvector
!       and rescale by the s-coefficients for later efficiency.
        DO l=1, n_profile
          rescale(l)=c_ratio(l)
          eig_vec(l, 1, k)=eig_vec(l, 1, k)*rescale(l)
          normalization(l)=eig_vec(l, 1, k)*eig_vec(l, 1, k)
        ENDDO
        DO j=2, 2*n_red_eigensystem
          DO l=1, n_profile
            rescale(l)=rescale(l)*c_ratio(l)
            eig_vec(l, j, k)=eig_vec(l, j, k)*rescale(l)
            normalization(l)=normalization(l) &
              +eig_vec(l, j, k)*eig_vec(l, j, k)
          ENDDO
        ENDDO
        DO l=1, n_profile
          normalization(l)=sqrt(1.0e+00_RealK/normalization(l))
        ENDDO
        DO j=1, 2*n_red_eigensystem
          DO l=1, n_profile
            eig_vec(l, j, k)=eig_vec(l, j, k)*normalization(l) &
              /sqs(l, j+ms-1)
          ENDDO
        ENDDO
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE EIG_SYS
!+ Subroutine to calculate spherical harmonics excluding expoential.
!
! Purpose:
!   Spherical harmonics, Upsilon_lm, are calculated for given directions
!   for all values of l at a fixed value of m.
!
! Method:
!   Y_mm is known so upward recurrence on l is used.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE eval_uplm(ms, n_max_order, n_direction, x &
         , up_lm &
         , nd_direction &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays
      INTEGER, Intent(IN) :: &
           nd_direction
!             Maximum number of directions
!
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          ms &
!           Azimuthal quantum number of spherical harmonic
        , n_max_order
!           Maximum order of harmonics to calculate
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of directions
      REAL  (RealK), Intent(IN) :: &
          x(nd_direction)
!           Cosines of polar angels of viewing directions
      REAL  (RealK), Intent(OUT) :: &
          up_lm(nd_direction, n_max_order+1-ms)
!           Non-azimuthal parts of spherical harmonics
!
!
!     Local variables
      INTEGER &
          ls &
!           Loop variable
        , j &
!           Loop variable
        , k
!           Loop variable
      REAL  (RealK) :: &
          l &
!           Principal quantum number of harmonic
        , m &
!           Azimuthal quantum number of harmonic
        , product
!           Factorial terms in Y_lm
!
!
!
!     Start the recurrence for Y_mm.
      product=1.0e+00_RealK
      m=real(ms, RealK)
      IF (ms > 0) THEN
        DO j=1, ms
          product=(1.0e+00_RealK-5.0e-01_realk/real(j, realk))*product
        ENDDO
        DO k=1, n_direction
          up_lm(k, 1)=(-1.0e+00_RealK)**ms &
            *sqrt((1.0e+00_RealK-x(k)*x(k))**ms*product &
            *(2.0e+00_RealK*m+1.0e+00_realk)/(4.0e+00_realk*pi))
        ENDDO
      ELSE
        DO k=1, n_direction
          up_lm(k, 1)=1.0e+00_RealK/sqrt(4.0e+00_realk*pi)
        ENDDO
      ENDIF
!
!
!     Calculate Y_(m+1),m if it is within bounds.
      IF (ms < n_max_order) THEN
        DO k=1, n_direction
          up_lm(k, 2)=x(k)*sqrt(2.0e+00_RealK*m+3.0e+00_realk) &
            *up_lm(k, 1)
        ENDDO
      ENDIF
!
!
!     Complete the recurrence on l.
      DO ls=ms+2, n_max_order
        l=real(ls, RealK)
        DO k=1, n_direction
          up_lm(k, ls+1-ms)=x(k) &
            *sqrt(((2.0e+00_RealK*l-1.0e+00_realk) &
            *(2.0e+00_RealK*l+1.0e+00_realk)) &
            /((l+m)*(l-m)))*up_lm(k, ls-ms) &
            -sqrt(((2.0e+00_RealK*l+1.0e+00_realk) &
            *(l-1.0e+00_RealK-m)*(l-1.0e+00_realk+m)) &
            /((2.0e+00_RealK*l-3.0e+00_realk)*(l+m)*(l-m))) &
            *up_lm(k, ls-1-ms)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE EVAL_UPLM
!+ Subroutine to mimic a vector exponential function.
!
! Method:
!        The normal exponential function is called on an array
!        of input values. This is provided for systems where
!       there is no intrinsic EXP_V.
!
! Current owner of code: J. M. Edwards
!
! History:
!         Version            Date                          Comment
!         1.0                   12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77 with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE exp_v(n, a, b)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n
!           Number of values to exponentiate
      REAL  (RealK), Intent(IN) :: &
          a(n)
!           Arguments to exponentials
      REAL  (RealK), Intent(OUT) :: &
          b(n)
!           Output arguments
!
!
!     Local variables:
      INTEGER &
          i
!           Loop variable
!
!
!
      DO i=1, n
        b(i)=exp(a(i))
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE EXP_V
!+ Subroutine to calculate the absorptive extinctions of gases.
!
! Method:
!        Straightforward.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE gas_optical_properties(n_profile, n_layer &
         , n_gas, i_gas_pointer, k_esft_mono, gas_mix_ratio &
         , k_gas_abs &
         , nd_profile, nd_layer, nd_species &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
           nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_species
!           Size allocated for gaseous species
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_gas &
!           Number of gases
        , i_gas_pointer(nd_species)
!           Pointers to active gases
      REAL  (RealK), Intent(IN) :: &
          k_esft_mono(nd_species) &
!           ESFT exponents for each gas
        , gas_mix_ratio(nd_profile, nd_layer, nd_species)
!           Gas mixing ratios
      REAL  (RealK), Intent(OUT) :: &
          k_gas_abs(nd_profile, nd_layer)
!           Clear absorptive extinction
!
!     Local variables.
      INTEGER &
          i_gas &
!           Temporary gas `index''
        , l &
!           Loop variable
        , i &
!           Loop variable
        , j
!           Loop variable
!
!
!     Calculate the absorption for the first gas and add on the rest.
      i_gas=i_gas_pointer(1)
      DO j=1, nd_layer
        DO l=1, nd_profile
          k_gas_abs(l, j) &
            =k_esft_mono(i_gas)*gas_mix_ratio(l, j, i_gas)
        ENDDO
      ENDDO
      DO i=2, n_gas
      i_gas=i_gas_pointer(i)
        DO j=1, nd_layer
          DO l=1, nd_profile
            k_gas_abs(l, j)=k_gas_abs(l, j) &
              +k_esft_mono(i_gas)*gas_mix_ratio(l, j, i_gas)
          ENDDO
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE GAS_OPTICAL_PROPERTIES
!+ Subroutine to calculate fluxes using gaussian quadrature.
!
! Method:
!        Fluxes are calculated by using gaussian quadrature for
!        the angular integration. This is not a full implementation
!        of gaussian quadrature for multiple scattering, but is
!        intended only for non-scattering calculations in the
!        infra-red. In this case, the fluxes can be calculated as
!        a weighted sum of two-stream fluxes where the diffusivity
!        factors for the two-stream approximations are determined
!        from the gaussian points.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE gauss_angle(n_profile, n_layer &
         , n_order_gauss &
         , tau &
         , flux_inc_down &
         , diff_planck, source_ground, albedo_surface_diff &
         , flux_diffuse &
         , l_ir_source_quad, diff_planck_2 &
         , nd_profile, nd_layer &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE angular_integration_pcf
      USE spectral_region_pcf
      USE gaussian_weight_pcf, only : gauss_weight, gauss_point
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer
!           Maximum number of layers
!
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_order_gauss
!           Order of gaussian integration
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use quadratic source term
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, nd_layer) &
!           Optical depth
        , albedo_surface_diff(nd_profile) &
!           Diffuse albedo
        , flux_inc_down(nd_profile) &
!           Incident total flux
        , diff_planck(nd_profile, nd_layer) &
!           Difference in pi*Planckian function
        , source_ground(nd_profile) &
!           Ground source function
        , diff_planck_2(nd_profile, nd_layer)
!             2x2nd differences of Planckian
      REAL  (RealK), Intent(OUT) :: &
          flux_diffuse(nd_profile, 2*nd_layer+2)
!           Diffuse fluxes
!
!     Local variabales.
      INTEGER &
          i &
!           Loop variable
        , l &
!           Loop variable
        , k
!           Loop variable
      REAL  (RealK) :: &
          flux_stream(nd_profile, 2*nd_layer+2) &
!           Flux in stream
        , secant_ray &
!           Secant of angle with vertical
        , diff_planck_rad(nd_profile, nd_layer) &
!           Difference in pi*Planckian function
        , diff_planck_rad_2(nd_profile, nd_layer) &
!             2x2nd differences of Planckian
        , source_ground_rad(nd_profile) &
!           Ground source function
        , radiance_inc(nd_profile) &
!           Incidnet radiance
        , weight_stream
!           Weighting for stream
!
!
!     Subroutines called:
!      EXTERNAL &
!           monochromatic_ir_radiance
!
!
!
!     Set the source function.
      DO l=1, n_profile
        source_ground_rad(l)=source_ground(l)/pi
        radiance_inc(l)=flux_inc_down(l)/pi
      ENDDO
      DO i=1, n_layer
        DO l=1, n_profile
          diff_planck_rad(l, i)=diff_planck(l, i)/pi
        ENDDO
      ENDDO
      DO i=1, 2*n_layer+2
        DO l=1, n_profile
          flux_diffuse(l, i)=0.0
        ENDDO
      ENDDO
      IF (l_ir_source_quad) THEN
        DO i=1, n_layer
          DO l=1, n_profile
            diff_planck_rad_2(l, i)=diff_planck_2(l, i)/pi
          ENDDO
        ENDDO
      ENDIF
!
!     Calculate the fluxes with a number of diffusivity factors
!     and sum the results.
      DO k=1, n_order_gauss
        secant_ray=2.0e+00_RealK &
          /(gauss_point(k, n_order_gauss)+1.0e+00_RealK)
!
!       Calculate the radiance at this angle.
        CALL monochromatic_ir_radiance(n_profile, n_layer &
          , tau &
          , radiance_inc &
          , diff_planck_rad, source_ground_rad, albedo_surface_diff &
          , secant_ray &
          , flux_stream &
          , nd_profile, nd_layer &
          )
!
!       Augment the flux by the amount in this stream.
        weight_stream=5.0e-01_RealK*pi*gauss_weight(k, n_order_gauss) &
          *(gauss_point(k, n_order_gauss)+1.0e+00_RealK)
        DO i=1, 2*n_layer+2
          DO l=1, n_profile
            flux_diffuse(l, i)=flux_diffuse(l, i) &
              +weight_stream*flux_stream(l, i)
          ENDDO
        ENDDO
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE GAUSS_ANGLE
!+ Subroutine to get a free unit number
!
! Purpose:
!   This subroutine finds a free unit number for output.
!
! Method:
!   Straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE get_free_unit(ierr, iunit)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE error_pcf
      USE def_std_io_icf
!
!
      IMPLICIT NONE
!
!
!
!     Dummy arguments:
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(OUT) :: &
          iunit
!           Unit number
!
!     Local variables:
      LOGICAL &
          l_open
!           Flag for open unit
!
!
!
      ierr=i_normal
      iunit=20
      INQUIRE(unit=iunit, opened=l_open)
      DO WHILE ( (l_open).AND.(iunit < 100) )
        IF (l_open) iunit=iunit+1
        INQUIRE(unit=iunit, opened=l_open)
      ENDDO
!
      IF (iunit > 100) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: No free units are available for i/o.'
        ierr=i_err_io
        RETURN
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE GET_FREE_UNIT
!+ Subroutine to calculate grey optical properties.
!
! Method:
!        For each activated optical process, excluding gaseous
!        absorption, increments are calculated for the total and
!        scattering extinctions, and the products of the asymmetry
!        factor and the forward scattering factor in clear and
!        cloudy regions. These increments are summed, and the grey
!        total and scattering extinctions and the asymmetry and forward
!        scattering factors are thus calculated.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
!DD+ -------------------------------------------------------------------
! Compiler directives for specific computer systems:
!
! Indirect addressing will inhibit vectorization, but here it is safe
! because all points are independent.
!
! Fujistu VPP700:
!OCL NOVREC
!
! Cray vector machines:
!cfpp$ nodepchk r
!
!DD- -------------------------------------------------------------------
   
      SUBROUTINE grey_opt_prop(ierr &
        , n_profile, n_layer, p, t, density &
        , n_order_phase, l_rescale, n_order_forward &
        , l_henyey_greenstein_pf, l_solar_phf, n_order_phase_solar &
        , n_direction, cos_sol_view &
        , l_rayleigh, rayleigh_coeff &
        , l_continuum, n_continuum, i_continuum_pointer, k_continuum &
        , amount_continuum &
        , l_aerosol, n_aerosol, aerosol_mix_ratio &
        , i_aerosol_parametrization &
        , i_humidity_pointer, humidities, delta_humidity &
        , mean_rel_humidity &
        , aerosol_absorption, aerosol_scattering, aerosol_phase_fnc &

        , n_opt_level_aerosol_prsc, aerosol_pressure_prsc &
        , aerosol_absorption_prsc, aerosol_scattering_prsc &
        , aerosol_phase_fnc_prsc &

        , l_cloud, n_cloud_profile, i_cloud_profile, n_cloud_top &
        , n_condensed, l_cloud_cmp, i_phase_cmp &
        , i_condensed_param, condensed_param_list &
        , condensed_mix_ratio, condensed_dim_char &
        , n_cloud_type, i_cloud_type &

        , n_opt_level_drop_prsc &
        , drop_pressure_prsc, drop_absorption_prsc &
        , drop_scattering_prsc, drop_phase_fnc_prsc &
        , n_opt_level_ice_prsc, ice_pressure_prsc &
        , ice_absorption_prsc, ice_scattering_prsc, ice_phase_fnc_prsc &

!                       Optical Properties
        , ss_prop &
        , nd_profile, nd_radiance_profile, nd_layer &
        , nd_layer_clr, id_ct &
        , nd_continuum, nd_aerosol_species, nd_humidities &
        , nd_cloud_parameter, nd_cloud_component &
        , nd_phase_term, nd_max_order, nd_direction &

        , nd_profile_aerosol_prsc, nd_profile_cloud_prsc &
        , nd_opt_level_aerosol_prsc, nd_opt_level_cloud_prsc &

        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE def_std_io_icf
      USE aerosol_parametrization_pcf
      USE cloud_scheme_pcf
      USE phase_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_radiance_profile &
!           Size allocated for profiles of quantities specifically
!           used in calulating radiances
        , nd_layer &
!           Size allocated for layers
        , nd_layer_clr &
!           Size allocated for completely clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_direction &
!           Size allocated for viewing directions
        , nd_aerosol_species &
!           Size allocated for aerosols
        , nd_humidities &
!           Size allocated for humidities
        , nd_continuum &
!           Size allocated for continua
        , nd_phase_term &
!           Size allocated for terms in the phase function
        , nd_max_order &
!           Size allocated for the order of the calculation
        , nd_cloud_parameter &
!           Size allocated for cloud parameters
        , nd_cloud_component &
!           Size allocated for components of clouds

        , nd_profile_aerosol_prsc &
!           Size allocated for profiles of prescribed
!           cloudy optical properties
        , nd_profile_cloud_prsc &
!           Size allocated for profiles of prescribed
!           aerosol optical properties
        , nd_opt_level_aerosol_prsc &
!           Size allocated for levels of prescribed
!           cloudy optical properties
        , nd_opt_level_cloud_prsc
!           Size allocated for levels of prescribed
!           aerosol optical properties

!
!     Inclusion of header files.
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!
!     Basic atmospheric properties:
!
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
!
      REAL  (RealK), Intent(IN) :: &
          p(nd_profile, nd_layer) &
!           Pressure
        , t(nd_profile, nd_layer) &
!           Temperature
        , density(nd_profile, nd_layer)
!           Density at levels
!
!
!     Optical switches:
      LOGICAL, Intent(IN) :: &
          l_rescale &
!           Delta-rescaling required
        , l_henyey_greenstein_pf &
!           Flag to use a Henyey-Greenstein phase function
        , l_solar_phf
!           Flag to use an extended phase function for solar
!           radiation
      INTEGER, Intent(IN) :: &
          n_order_phase &
!           Order of terms in the phase function
        , n_order_phase_solar &
!           Order of truncation of the solar beam
        , n_order_forward
!           Order used in forming the forward scattering parameter
!
!     Directional information
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          cos_sol_view(nd_radiance_profile, nd_direction)
!           Cosines of the angles between the solar direction
!           and the viewing direction
!
!
!     Rayleigh scattering:
!
      LOGICAL, Intent(IN) :: &
          l_rayleigh
!           Rayleigh scattering activated
!
      REAL  (RealK), Intent(IN) :: &
          rayleigh_coeff
!           Rayleigh coefficient
!
!
!     Continuum processes:
      LOGICAL, Intent(IN) :: &
          l_continuum
!           Continuum absorption activated
!
      INTEGER, Intent(IN) :: &
          n_continuum &
!           Number of continua
        , i_continuum_pointer(nd_continuum)
!           Pointers to active continua
!
      REAL  (RealK), Intent(IN) :: &
          k_continuum(nd_continuum) &
!           Continuum extinction
        , amount_continuum(nd_profile, nd_layer, nd_continuum)
!           Amounts for continua
!
!
!     Properties of aerosols:
!
      LOGICAL, Intent(IN) :: &
          l_aerosol
!           Aerosols activated
!
      INTEGER, Intent(IN) :: &
          n_aerosol &
!           Number of aerosol species
        , i_aerosol_parametrization(nd_aerosol_species) &
!           Parametrizations of aerosols
        , i_humidity_pointer(nd_profile,  nd_layer)
!           Pointer to aerosol look-up table
!
      REAL  (RealK), Intent(IN) :: &
          aerosol_mix_ratio(nd_profile, nd_layer &
            , nd_aerosol_species) &
!           Number densty of aerosols
        , aerosol_absorption(nd_humidities, nd_aerosol_species) &
!           Aerosol absorption in band for a mixing ratio of unity
        , aerosol_scattering(nd_humidities, nd_aerosol_species) &
!           Aerosol scattering in band for a mixing ratio of unity
        , aerosol_phase_fnc(nd_humidities &
            , nd_phase_term, nd_aerosol_species) &
!           Aerosol phase function in band
        , humidities(nd_humidities, nd_aerosol_species) &
!           Array of humidities
        , delta_humidity &
!           Increment in humidity
        , mean_rel_humidity(nd_profile, nd_layer)
!           Mixing ratio of water vapour
!

!     Observational properties of aerosols:
      INTEGER, Intent(IN) :: &
          n_opt_level_aerosol_prsc(nd_aerosol_species)
!           Number of levels of prescribed optical properties
!           of aerosols
!
      REAL  (RealK), Intent(IN) :: &
          aerosol_pressure_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, nd_aerosol_species) &
!           Pressures at which optical properties of aerosols
!           are prescribed
        , aerosol_absorption_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, nd_aerosol_species) &
!           Prescribed absorption by aerosols
        , aerosol_scattering_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, nd_aerosol_species) &
!           Prescribed scattering by aerosols
        , aerosol_phase_fnc_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc &
            , nd_phase_term, nd_aerosol_species)
!           Prescribed phase functions of aerosols

!
!
!     Properties of clouds:
!
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Clouds activated
!
!     Geometry of clouds:
!
      INTEGER, Intent(IN) :: &
          n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_type &
!           Number of types of clouds
        , n_cloud_profile(id_ct: nd_layer) &
!           Number of cloudy profiles in each layer
        , i_cloud_profile(nd_profile, id_ct: nd_layer) &
!           Profiles containing clouds
        , i_cloud_type(nd_cloud_component)
!           Types of cloud to which each component contributes
!
!     Microphysical quantities:
      INTEGER, Intent(IN) :: &
          n_condensed &
!           Number of condensed components
        , i_phase_cmp(nd_cloud_component) &
!           Phases of cloudy components
        , i_condensed_param(nd_cloud_component)
!           Parametrization schemes for cloudy components
!
      LOGICAL, Intent(IN) :: &
          l_cloud_cmp(nd_cloud_component)
!           Flags to activate cloudy components
!
      REAL  (RealK), Intent(IN) :: &
          condensed_param_list(nd_cloud_parameter &
            , nd_cloud_component) &
!           Coefficients in parametrization schemes
        , condensed_mix_ratio(nd_profile, id_ct: nd_layer &
            , nd_cloud_component) &
!           Mixing ratios of cloudy components
        , condensed_dim_char(nd_profile, id_ct: nd_layer &
            , nd_cloud_component)
!           Characteristic dimensions of cloudy components
!

!     Prescribed cloudy optical properties:
      INTEGER, Intent(IN) :: &
          n_opt_level_drop_prsc &
!           Number of levels of prescribed
!           optical properties of droplets
        , n_opt_level_ice_prsc
!           Number of levels of prescribed
!           optical properties of ice crystals
!
      REAL  (RealK), Intent(IN) :: &
          drop_pressure_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Pressures at which optical properties of
!           droplets are prescribed
        , drop_absorption_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Prescribed absorption by droplets
        , drop_scattering_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Prescribed scattering by droplets
        , drop_phase_fnc_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, nd_phase_term) &
!           Prescribed phase function of droplets
        , ice_pressure_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Pressures at which optical properties of
!           ice crystals are prescribed
        , ice_absorption_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Prescribed absorption by ice crystals
        , ice_scattering_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Prescribed scattering by ice crystals
        , ice_phase_fnc_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, nd_phase_term)
!           Prescribed phase functions of ice crystals

!
!
!     Calculated optical properties:
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!
!
!     Local variables.
      INTEGER &
          i_continuum &
!           Temporary continuum `index''
        , l &
!           Loop variable
        , ll &
!           Loop variable
        , i &
!           Loop variable
        , id &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , ls &
!           Loop variable
        , n_index &
!           Number of indices satisfying the test
        , index(nd_profile)
!           Indices satifying the test
!
!     Temporary optical properties:
!
      REAL  (RealK) :: &
          k_ext_scat_cloud_comp(nd_profile, id_ct: nd_layer) &
!           Scattering extinction of cloudy component
        , k_ext_tot_cloud_comp(nd_profile, id_ct: nd_layer) &
!           Total extinction of cloudy component
        , phase_fnc_cloud_comp(nd_profile, id_ct: nd_layer &
            , nd_max_order) &
!           Phase function of cloudy components
        , phase_fnc_solar_cloud_comp(nd_radiance_profile &
            , id_ct: nd_layer, nd_direction) &
!           Phase function of cloudy components for singly scattered
!           solar radiation
        , forward_scatter_cloud_comp(nd_profile, id_ct: nd_layer) &
!           Forward scattering of cloudy component
        , forward_solar_cloud_comp(nd_profile, id_ct: nd_layer)
!           Forward scattering for the solar beam
!           in the cloudy component
!
!     Subroutines called:
!      EXTERNAL &
!          opt_prop_aerosol, opt_prop_water_cloud, opt_prop_ice_cloud
!
!
!
!     Initialize the extinction coefficients and the phase function.
!hmjb      DO i=1, n_cloud_top-1
!hmjb        DO l=1, n_profile
!hmjb          ss_prop%k_grey_tot_clr(l, i)=0.0_RealK
!hmjb          ss_prop%k_ext_scat_clr(l, i)=0.0_RealK
!hmjb        ENDDO
!hmjb      ENDDO
!CDIR COLLAPSE
      DO i=id_ct, nd_layer
        DO l=1, nd_profile
          ss_prop%k_grey_tot(l, i, 0)=0.0_RealK
          ss_prop%k_ext_scat(l, i, 0)=0.0_RealK
        ENDDO
      ENDDO
!CDIR COLLAPSE
      DO ls=1, n_order_phase
!hmjb        DO i=1, n_cloud_top-1
!hmjb          DO l=1, n_profile
!hmjb            ss_prop%phase_fnc_clr(l, i, ls)=0.0_RealK
!hmjb          ENDDO
!hmjb        ENDDO
        DO i=1, nd_layer
          DO l=id_ct, nd_profile
            ss_prop%phase_fnc(l, i, ls, 0)=0.0_RealK
          ENDDO
        ENDDO
      ENDDO
!     Forward scattering is required only when delta-rescaling
!     is performed.
      IF (l_rescale) THEN
!hmjb        DO i=1, n_cloud_top-1
!hmjb          DO l=1, n_profile
!hmjb            ss_prop%forward_scatter_clr(l, i)=0.0_RealK
!hmjb          ENDDO
!hmjb        ENDDO
!CDIR COLLAPSE
        DO i=id_ct, nd_layer
          DO l=1, nd_profile
            ss_prop%forward_scatter(l, i, 0)=0.0_RealK
          ENDDO
        ENDDO
      ENDIF
!     If using a separate solar phase function that must be initialized.
      IF (l_solar_phf) THEN
!CDIR COLLAPSE
        DO id=1, n_direction
!hmjb          DO i=1, n_cloud_top-1
!hmjb            DO l=1, n_profile
!hmjb              ss_prop%phase_fnc_solar_clr(l, i, id)=0.0_RealK
!hmjb            ENDDO
!hmjb          ENDDO
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              ss_prop%phase_fnc_solar(l, i, id, 0)=0.0_RealK
            ENDDO
          ENDDO
        ENDDO
!hmjb        DO i=1, n_cloud_top-1
!hmjb          DO l=1, n_profile
!hmjb            ss_prop%forward_solar_clr(l, i)=0.0_RealK
!hmjb          ENDDO
!hmjb        ENDDO
!CDIR COLLAPSE
        DO i=id_ct, nd_layer
          DO l=1, nd_profile
            ss_prop%forward_solar(l, i, 0)=0.0_RealK
          ENDDO
        ENDDO
      ENDIF
!
!
!
!
!
!     Consider each optical process in turn.
!
!     Rayleigh scattering:
!
      IF (l_rayleigh) THEN
!hmjb        DO i=1, n_cloud_top-1
!hmjb          DO l=1, n_profile
!hmjb            ss_prop%k_ext_scat_clr(l, i) &
!hmjb              =ss_prop%k_ext_scat_clr(l, i)+rayleigh_coeff
!hmjb          ENDDO
!hmjb        ENDDO
!CDIR COLLAPSE
        DO i=id_ct, nd_layer
          DO l=1, nd_profile
            ss_prop%k_ext_scat(l, i, 0) &
              =ss_prop%k_ext_scat(l, i, 0)+rayleigh_coeff
          ENDDO
        ENDDO
!
!       Only the second Lengendre polynomial contributes.
        IF (n_order_phase >= 2) THEN
!hmjb          DO i=1, n_cloud_top-1
!hmjb            DO l=1, n_profile
!hmjb              ss_prop%phase_fnc_clr(l, i, 2) &
!hmjb                =ss_prop%phase_fnc_clr(l, i, 2) &
!hmjb                +rayleigh_coeff*1.0e-01_RealK
!hmjb            ENDDO
!hmjb          ENDDO
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              ss_prop%phase_fnc(l, i, 2, 0) &
                =ss_prop%phase_fnc(l, i, 2, 0) &
                +rayleigh_coeff*1.0e-01_RealK
            ENDDO
          ENDDO
        ENDIF
!
!       No formal rescaling is applied to the phase function for
!       Rayleigh scattering, as only g_2 is non-zero.
!
        IF (l_solar_phf) THEN
!
          DO id=1, n_direction
!hmjb            DO i=1, n_cloud_top-1
!hmjb              DO l=1, n_profile
!hmjb                ss_prop%phase_fnc_solar_clr(l, i, id) &
!hmjb                  =ss_prop%phase_fnc_solar_clr(l, i, id) &
!hmjb                  +rayleigh_coeff &
!hmjb                  *0.75_RealK*(1.0_realk+cos_sol_view(l, id)**2)
!hmjb              ENDDO
!hmjb            ENDDO
!CDIR COLLAPSE
            DO i=id_ct, nd_layer
              DO l=1, nd_profile
                ss_prop%phase_fnc_solar(l, i, id, 0) &
                  =ss_prop%phase_fnc_solar(l, i, id, 0) &
                  +rayleigh_coeff &
                  *0.75_RealK*(1.0_realk+cos_sol_view(l, id)**2)
              ENDDO
            ENDDO
          ENDDO
!
        ENDIF
!
      ENDIF
!
      IF (l_aerosol) THEN
!       Include the effects of aerosol.
!       Above clouds.
!        CALL opt_prop_aerosol(ierr &
!          , n_profile, 1, n_cloud_top-1 &
!       Within clouds:
!        CALL opt_prop_aerosol(ierr &
!          , n_profile, n_cloud_top, n_layer &

!hmjb == just one call to do the full column

        CALL opt_prop_aerosol(ierr &
          , n_profile, 1, n_layer &
          , n_order_phase, l_rescale, n_order_forward &
          , l_henyey_greenstein_pf &
          , n_aerosol, aerosol_mix_ratio &
          , i_aerosol_parametrization &
          , i_humidity_pointer, humidities, delta_humidity &
          , mean_rel_humidity &
          , aerosol_absorption, aerosol_scattering, aerosol_phase_fnc &
          , l_solar_phf, n_order_phase_solar, n_direction, cos_sol_view &

          , p, density &
          , n_opt_level_aerosol_prsc, aerosol_pressure_prsc &
          , aerosol_absorption_prsc, aerosol_scattering_prsc &
          , aerosol_phase_fnc_prsc &

          , ss_prop%k_grey_tot(:, :, 0) &
          , ss_prop%k_ext_scat(:, :, 0) &
          , ss_prop%phase_fnc(:, :, :, 0) &
          , ss_prop%forward_scatter(:, :, 0) &
          , ss_prop%forward_solar(:, :, 0) &
          , ss_prop%phase_fnc_solar(:, :, :, 0) &
          , nd_profile, nd_radiance_profile, nd_layer &
          , id_ct, nd_layer &
          , nd_aerosol_species, nd_humidities &
          , nd_phase_term, nd_max_order, nd_direction &

          , nd_profile_aerosol_prsc, nd_opt_level_aerosol_prsc &

          )
      ENDIF
!
      IF (l_continuum) THEN
!       Include continuum absorption.
!CDIR COLLAPSE
        DO j=1, n_continuum
          i_continuum=i_continuum_pointer(j)
!hmjb          DO i=1, n_cloud_top-1
!hmjb            DO l=1, n_profile
!hmjb              ss_prop%k_grey_tot_clr(l, i)=ss_prop%k_grey_tot_clr(l, i) &
!hmjb                +k_continuum(i_continuum) &
!hmjb                *amount_continuum(l, i, i_continuum)
!hmjb            ENDDO
!hmjb          ENDDO
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              ss_prop%k_grey_tot(l, i, 0)=ss_prop%k_grey_tot(l, i, 0) &
                +k_continuum(i_continuum) &
                *amount_continuum(l, i, i_continuum)
            ENDDO
          ENDDO
        ENDDO
      ENDIF
!
!
!     Add the scattering on to the total extinction. The final clear-sky
!     phase function not calculated here since the product of the phase
!     function and scattering is also needed to calculate the cloudy
!     phase function.
!hmjb      DO i=1, n_cloud_top-1
!hmjb        DO l=1, n_profile
!hmjb          ss_prop%k_grey_tot_clr(l, i)=ss_prop%k_grey_tot_clr(l, i) &
!hmjb            +ss_prop%k_ext_scat_clr(l, i)
!hmjb        ENDDO
!hmjb      ENDDO
!CDIR COLLAPSE
      DO i=id_ct, nd_layer
        DO l=1, nd_profile
          ss_prop%k_grey_tot(l, i, 0)=ss_prop%k_grey_tot(l, i, 0) &
            +ss_prop%k_ext_scat(l, i, 0)
        ENDDO
      ENDDO
!
!
!     If there are no clouds calculate the final optical properties
!     and return to the calling routine.
!
      IF (.NOT.l_cloud) THEN
!
!CDIR COLLAPSE
        DO ls=1, n_order_phase
!hmjb          DO i=1, n_cloud_top-1
!hmjb            DO l=1, n_profile
!hmjb              IF (ss_prop%k_ext_scat_clr(l, i) > 0.0_RealK) THEN
!hmjb                ss_prop%phase_fnc_clr(l, i, ls) &
!hmjb                  =ss_prop%phase_fnc_clr(l, i, ls) &
!hmjb                  /ss_prop%k_ext_scat_clr(l, i)
!hmjb              ENDIF
!hmjb            ENDDO
!hmjb          ENDDO
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              IF (ss_prop%k_ext_scat(l, i, 0) > 0.0_RealK) THEN
                ss_prop%phase_fnc(l, i, ls, 0) &
                  =ss_prop%phase_fnc(l, i, ls, 0) &
                  /ss_prop%k_ext_scat(l, i, 0)
              ENDIF
            ENDDO
          ENDDO
        ENDDO
!
        IF (l_rescale) THEN
!hmjb          DO i=1, n_cloud_top-1
!hmjb            DO l=1, n_profile
!hmjb              IF (ss_prop%k_ext_scat_clr(l, i) > 0.0_RealK) THEN
!hmjb                ss_prop%forward_scatter_clr(l, i) &
!hmjb                  =ss_prop%forward_scatter_clr(l, i) &
!hmjb                  /ss_prop%k_ext_scat_clr(l, i)
!hmjb              ENDIF
!hmjb            ENDDO
!hmjb          ENDDO
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              IF (ss_prop%k_ext_scat(l, i, 0) > 0.0_RealK) THEN
                ss_prop%forward_scatter(l, i, 0) &
                  =ss_prop%forward_scatter(l, i, 0) &
                  /ss_prop%k_ext_scat(l, i, 0)
              ENDIF
            ENDDO
          ENDDO
!
        ENDIF
!
        IF (l_solar_phf) THEN
!
!hmjb          DO i=1, n_cloud_top-1
!hmjb            DO l=1, n_profile
!hmjb              IF (ss_prop%k_ext_scat_clr(l, i) > 0.0_RealK) THEN
!hmjb                ss_prop%forward_solar_clr(l, i) &
!hmjb                  =ss_prop%forward_solar_clr(l, i) &
!hmjb                  /ss_prop%k_ext_scat_clr(l, i)
!hmjb              ENDIF
!hmjb            ENDDO
!hmjb          ENDDO
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              IF (ss_prop%k_ext_scat(l, i, 0) > 0.0_RealK) THEN
                ss_prop%forward_solar(l, i, 0) &
                  =ss_prop%forward_solar(l, i, 0) &
                  /ss_prop%k_ext_scat(l, i, 0)
              ENDIF
            ENDDO
          ENDDO
!
!CDIR COLLAPSE
          DO id=1, n_direction
!hmjb            DO i=1, n_cloud_top-1
!hmjb              DO l=1, n_profile
!hmjb                IF (ss_prop%k_ext_scat_clr(l, i) > 0.0_RealK) &
!hmjb                  ss_prop%phase_fnc_solar_clr(l, i, id) &
!hmjb                    =ss_prop%phase_fnc_solar_clr(l, i, id) &
!hmjb                    /ss_prop%k_ext_scat_clr(l, i)
!hmjb              ENDDO
!hmjb            ENDDO
            DO i=id_ct, nd_layer
              DO l=1, nd_profile
                IF (ss_prop%k_ext_scat(l, i, 0) > 0.0_RealK) &
                  ss_prop%phase_fnc_solar(l, i, id, 0) &
                    =ss_prop%phase_fnc_solar(l, i, id, 0) &
                    /ss_prop%k_ext_scat(l, i, 0)
              ENDDO
            ENDDO
          ENDDO
!
        ENDIF
!
        RETURN
!
      ENDIF
!
!
!
!
!     Addition of cloudy properties:
!
!
!     Add in background contibutions:
!
!
!     All the processes occurring outside clouds also occur
!     within them.
!CDIR COLLAPSE
      DO k=1, n_cloud_type
        DO i=id_ct, nd_layer
          DO l=1, nd_profile
            ss_prop%k_grey_tot(l, i, k)=ss_prop%k_grey_tot(l, i, 0)
            ss_prop%k_ext_scat(l, i, k)=ss_prop%k_ext_scat(l, i, 0)
            ss_prop%forward_scatter(l, i, k) &
              =ss_prop%forward_scatter(l, i, 0)
            ss_prop%forward_solar(l, i, k) &
              =ss_prop%forward_solar(l, i, 0)
          ENDDO
        ENDDO
        DO ls=1, n_order_phase
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              ss_prop%phase_fnc(l, i, ls, k) &
                =ss_prop%phase_fnc(l, i, ls, 0)
            ENDDO
          ENDDO
        ENDDO
!       If using a separate solar phase function that must
!       be initialized.
        IF (l_solar_phf) THEN
          DO id=1, n_direction
            DO i=id_ct, nd_layer
              DO l=1, nd_profile
                ss_prop%phase_fnc_solar(l, i, id, k) &
                  =ss_prop%phase_fnc_solar(l, i, id, 0)
              ENDDO
            ENDDO
          ENDDO
        ENDIF
      ENDDO
!
!
!
!     Add on the terms representing processes within clouds.
!
!     Loop over the condensed components, calculating their optical
!     properties and then assign them to the arrays for the types of
!     cloud.
!
      DO k=1, n_condensed
!
!       Flags for dealing with components were set in the subroutine
!       set_cloud_pointer. we now determine whether the component is
!       to be included and calculate its optical properties according
!       to the phase of the component. these contributions are added
!       to the arrays for the selected type of cloud.
!
        IF (l_cloud_cmp(k)) THEN
!
          IF (i_phase_cmp(k) == IP_phase_water) THEN
!
!           Include scattering by water droplets.
!
            CALL opt_prop_water_cloud(ierr &
              , n_profile, n_layer, n_cloud_top &
              , n_cloud_profile, i_cloud_profile &
              , n_order_phase, l_rescale, n_order_forward &
              , l_henyey_greenstein_pf, l_solar_phf &
              , n_order_phase_solar, n_direction, cos_sol_view &
              , i_condensed_param(k) &
              , condensed_param_list(1, k) &
              , condensed_mix_ratio(1, id_ct, k) &
              , condensed_dim_char(1, id_ct, k) &

              , p, density &
              , n_opt_level_drop_prsc, drop_pressure_prsc &
              , drop_absorption_prsc, drop_scattering_prsc &
              , drop_phase_fnc_prsc &

              , k_ext_tot_cloud_comp, k_ext_scat_cloud_comp &
              , phase_fnc_cloud_comp, forward_scatter_cloud_comp &
              , forward_solar_cloud_comp, phase_fnc_solar_cloud_comp &
              , nd_profile, nd_radiance_profile, nd_layer, id_ct &
              , nd_direction, nd_phase_term, nd_max_order &
              , nd_cloud_parameter &

              , nd_profile_cloud_prsc, nd_opt_level_cloud_prsc &

              )
!
          ELSE IF (i_phase_cmp(k) == IP_phase_ice) THEN
!
!           Include scattering by ice crystals.
!
            CALL opt_prop_ice_cloud(ierr &
              , n_profile, n_layer, n_cloud_top &
              , n_cloud_profile, i_cloud_profile &
              , n_order_phase, l_rescale, n_order_forward &
              , l_henyey_greenstein_pf, l_solar_phf &
              , n_order_phase_solar, n_direction, cos_sol_view &
              , i_condensed_param(k) &
              , condensed_param_list(1, k) &
              , condensed_mix_ratio(1, id_ct, k) &
              , condensed_dim_char(1, id_ct, k) &

              , p, t, density &
              , n_opt_level_ice_prsc, ice_pressure_prsc &
              , ice_absorption_prsc, ice_scattering_prsc &
              , ice_phase_fnc_prsc &




              , k_ext_tot_cloud_comp, k_ext_scat_cloud_comp &
              , phase_fnc_cloud_comp, forward_scatter_cloud_comp &
              , forward_solar_cloud_comp, phase_fnc_solar_cloud_comp &
              , nd_profile, nd_radiance_profile, nd_layer, id_ct &
              , nd_direction &
              , nd_phase_term, nd_max_order, nd_cloud_parameter &

              , nd_profile_cloud_prsc, nd_opt_level_cloud_prsc &

              )
!
          ENDIF
!
!
!
!         Increment the arrays of optical properties.
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer 
             DO l=1, nd_profile
              ss_prop%k_grey_tot(l, i, i_cloud_type(k)) &
                =ss_prop%k_grey_tot(l, i, i_cloud_type(k)) &
                +k_ext_tot_cloud_comp(l, i)
              ss_prop%k_ext_scat(l, i, i_cloud_type(k)) &
                =ss_prop%k_ext_scat(l, i, i_cloud_type(k)) &
                +k_ext_scat_cloud_comp(l, i)
            ENDDO
          ENDDO
!CDIR COLLAPSE
          DO ls=1, n_order_phase
            DO i=id_ct, nd_layer 
               DO l=1, nd_profile
                ss_prop%phase_fnc(l, i, ls, i_cloud_type(k)) &
                  =ss_prop%phase_fnc(l, i, ls, i_cloud_type(k)) &
                  +phase_fnc_cloud_comp(l, i, ls)
              ENDDO
            ENDDO
          ENDDO
          IF (l_rescale) THEN
!CDIR COLLAPSE
            DO i=id_ct, nd_layer 
              DO l=1, nd_profile
                ss_prop%forward_scatter(l, i, i_cloud_type(k)) &
                  =ss_prop%forward_scatter(l, i, i_cloud_type(k)) &
                  +forward_scatter_cloud_comp(l, i)
              ENDDO
            ENDDO
          ENDIF
          IF (l_solar_phf) THEN
!CDIR COLLAPSE
            DO i=id_ct, nd_layer 
              DO l=1, nd_profile
                ss_prop%forward_solar(l, i, i_cloud_type(k)) &
                  =ss_prop%forward_solar(l, i, i_cloud_type(k)) &
                  +forward_solar_cloud_comp(l, i)
              ENDDO
            ENDDO
!CDIR COLLAPSE
            DO id=1, n_direction
              DO i=id_ct, nd_layer 
                DO l=1, nd_profile
                  ss_prop%phase_fnc_solar(l, i, id, i_cloud_type(k)) &
                    =ss_prop%phase_fnc_solar(l, i, id, i_cloud_type(k)) &
                    +phase_fnc_solar_cloud_comp(l, i, id)
                ENDDO
              ENDDO
            ENDDO
          ENDIF
!
        ENDIF
!
      ENDDO
!
!
!
!
!     Calculate the final optical properties.
!     The scattering was included in the free total extinction earlier,
!     but we have yet to divide the product of the phase function and
!     the scattering by the mean scattering.
!
!hmjb: It takes much longer to follow the indexes than
! to do the full matrix at once. It also faster to do from 1..n_layer
! instead of 1..n_cloud_top and then n_cloud_top..n_layer
! The new code follows below.

!hmjb: PROBLEM WITH VECTORIZATION ON SX6. INVERTING THE i,j LOOPS GIVES
! DIFFERENTE RESULTS, UNLESS ONE USES THE NOVECTOR OPTION. BECAUSE IT IS
! A PROBLEM OF SX6 ARCHITECTURE AND NOT OF THE CODE, I DID INVERT THE LOOP
! BECAUSE IT IS FASTER THIS WAY.
!      THE TIME TO RUN THE SUBROUTINE WAS REDUCED BY A FACTOR OF 15 (FIFTEEN).
!      ORIGINAL CODE TOOK 30% OF ALL RADIATION TIME.
!
!CDIR COLLAPSE
      DO k=0, n_cloud_type
        DO ls=1, n_order_phase
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              IF (ss_prop%k_ext_scat(l, i, k) > 0.0_RealK) THEN
                ss_prop%phase_fnc(l, i, ls, k) &
                  =ss_prop%phase_fnc(l, i, ls, k) &
                  /ss_prop%k_ext_scat(l, i, k)
              ENDIF
            ENDDO
          ENDDO
        ENDDO
      ENDDO

      IF (l_rescale) THEN
!CDIR COLLAPSE
        DO k=0, n_cloud_type
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              IF (ss_prop%k_ext_scat(l, i, k) > 0.0_RealK) THEN
                ss_prop%forward_scatter(l, i, k) &
                  =ss_prop%forward_scatter(l, i, k) &
                  /ss_prop%k_ext_scat(l, i, k)
              ENDIF
            ENDDO
          ENDDO
        ENDDO
      ENDIF

      IF (l_solar_phf) THEN
!CDIR COLLAPSE
        DO k=0, n_cloud_type
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              IF (ss_prop%k_ext_scat(l, i, k) > 0.0_RealK) THEN
                ss_prop%forward_solar(l, i, k) &
                  =ss_prop%forward_solar(l, i, k) &
                  /ss_prop%k_ext_scat(l, i, k)
              ENDIF
            ENDDO
          ENDDO
        ENDDO
!CDIR COLLAPSE
        DO k=0, n_cloud_type
          DO id=1, n_direction
            DO i=id_ct, nd_layer
              DO l=1, nd_profile
                IF (ss_prop%k_ext_scat(l, i, k) > 0.0_RealK) THEN
                  ss_prop%phase_fnc_solar(l, i, id, k) &
                    =ss_prop%phase_fnc_solar(l, i, id, k) &
                    /ss_prop%k_ext_scat(l, i, k)
                ENDIF
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDIF

!
!
!
      RETURN
      END SUBROUTINE GREY_OPT_PROP
!+ Subroutine to calculate hemispheric spherical integrals.
!
! Purpose:
!   This routine calculates hemispheric integrals of products
!   of spherical harmonics for a fixed azimuthal order for use
!   in Marshak''s boundary conditions.
!
! Method:
!
!   We require the integral of Y_l''^m* Y_l^m over the downward
!   hemisphere for those l'' such that l'+m is odd. If l=l' the
!   integral is trivially 1/2, but otherwise it will be zero
!   unless l+l'' is odd. To reduce storage we omit the case l=l'
!   here and then map
!       (l'', l) --> ( (l'-m+1)/2, (l-m+2)/2)
!   in the stored array.
!
!   The integrals are evaluated from the values of spherical
!   harmonics and their derivatives at a polar angle of pi/2.
!
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE hemi_sph_integ(ls_trunc, ms, uplm_zero &
        , kappa &
        , nd_max_order &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_max_order
!           Size allocated for orders of spherical harmonics
!
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          ls_trunc &
!           The truncating order of the system of equations
        , ms
!           Azimuthal order
      REAL  (RealK), Intent(IN) :: &
          uplm_zero(ls_trunc+1-ms)
!           Spherical harmonics and derivatives at a polar angle of
!           pi/2
!
      REAL  (RealK), Intent(OUT) :: &
          kappa(nd_max_order/2, nd_max_order/2)
!           Integrals of pairs of spherical harmonics over the downward
!           hemisphere
!
!     Local variables:
      INTEGER &
          lsr_p &
!           Reduced primed polar order
        , lsr
!           Reduced polar order
!
!
!
!     The outer loop is over l'' where l'+m is odd. Indexing is done
!     using the reduced indices l''+1-m and l+1-m.
!
      DO lsr_p=2, ls_trunc+1-ms, 2
        DO lsr=1, ls_trunc-ms, 2
          kappa(lsr_p/2, (lsr+1)/2)=2.0e+00_RealK*pi &
            *real(1-2*mod(lsr_p, 2), RealK) &
            *uplm_zero(lsr)*uplm_zero(lsr_p) &
            /real((lsr-lsr_p)*(lsr+lsr_p-1+2*ms), RealK)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE HEMI_SPH_INTEG
!+ Subroutine to increment radiances at a given azimuthal order.
!
! Method:
!   The weights of the terms in the complementary function
!   of the direct solution by spherical harmonics, u_{imk}^+-
!   are now available. For each viewing level and direction
!   we multiply by the precalculated coefficients and the
!   factor representing the azimuthal dependence to complete the
!   calculation of the radiance.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE increment_rad_cf(n_profile &
        , n_direction, azim_factor &
        , n_viewing_level, i_rad_layer &
        , i_sph_mode, i_sph_algorithm, ms, ls_trunc, euler_factor &
        , isolir, mu_0, kappa, up_lm &
        , n_red_eigensystem, n_equation, weight_u, upm &
        , i_direct, c_ylm, flux_direct, flux_total &
        , radiance, j_radiance &
        , nd_profile, nd_flux_profile &
        , nd_radiance_profile, nd_j_profile &
        , nd_layer, nd_direction, nd_viewing_level &
        , nd_max_order, nd_sph_equation, nd_sph_cf_weight &
        , nd_sph_u_range &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
      USE spectral_region_pcf
      USE sph_mode_pcf
      USE sph_algorithm_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for points where radiances are calculated
        , nd_flux_profile &
!           Size allocated for profiles where fluxes are calculated
        , nd_radiance_profile &
!           Size allocated for profiles where radiances are calculated
        , nd_j_profile &
!           Size allocated for profiles where mean radiances
!           are calculated
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_direction &
!           Size allocated for order of spherical calculation
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_max_order &
!           Size allocated for orders of direct calculation of
!           spherical harmonics
        , nd_sph_equation &
!           Size allocated for spherical equations
        , nd_sph_cf_weight &
!           Size allocated for entities to be weighted by the C. F.
        , nd_sph_u_range
!           Size allowed for range of values of u^+|- contributing
!           on any viewing level
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile
!           Number of profiles
!
!     Spectral decomposition
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
!
!     Viewing geometry:
      INTEGER, Intent(IN) :: &
          n_direction &
!           Number of directions in which radiances are calculated
        , n_viewing_level &
!           Number of levels where the radiance is calculated
        , i_rad_layer(nd_viewing_level)
!           Layers of the atmosphere in which viewing levels fall
      REAL  (RealK), Intent(IN) :: &
          azim_factor(nd_profile, nd_direction) &
!           Factors for representing the azimuthal dependence
        , mu_0(nd_profile) &
!           Cosines of the solar zenith angles
        , kappa(nd_max_order/2, nd_max_order/2) &
!           Integrals of Y_l^m*.Y_l^m over the downward hemisphere
        , up_lm(nd_profile, nd_max_order+1, nd_direction)
!           Polar parts of spherical harmonics
!
!     Angular integration:
      INTEGER, Intent(IN) :: &
          i_sph_mode &
!           Mode in which the spherical harmonic code is called
        , i_sph_algorithm &
!           Algorithm used to solve spherical harmonic problem
        , ms &
!           Azimuthal order of truncation
        , ls_trunc
!           Polar order of truncation
      REAL  (RealK), Intent(IN) :: &
          euler_factor
!           Factor weighting the last term of the series
!
!     Components of the solution of the linear system
      INTEGER, Intent(IN) :: &
          n_red_eigensystem &
!           Size of the reduced eigensystem
        , n_equation
!           Number of spherical equations
      REAL  (RealK), Intent(IN) :: &
          weight_u(nd_profile, nd_viewing_level &
            , nd_sph_cf_weight, nd_sph_u_range) &
!           Weights for coefficients in equations
        , upm(nd_profile, nd_sph_equation)
!           Variables u+|-
!
      REAL  (RealK), Intent(IN) :: &
          i_direct(nd_profile, 0: nd_layer)
!           Direct radiances
      REAL  (RealK), Intent(INOUT) :: &
          c_ylm(nd_profile, nd_viewing_level, ls_trunc+1-ms)
!           Spherical harmonic coefficients for radiances
!
!     Calculated radiances
      REAL  (RealK), Intent(INOUT) :: &
          radiance(nd_radiance_profile, nd_viewing_level, nd_direction)
!           Radiances
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct fluxes
        , flux_total(nd_flux_profile, 2*nd_layer+2)
!           Total fluxes
!
!           Mean radiances
      REAL  (RealK), Intent(OUT) :: &
          j_radiance(nd_j_profile, nd_viewing_level)
!           Mean radiances
!
!
!     Local arguments.
      INTEGER &
          l &
!           Loop variable
        , k &
!           Loop variable
        , id &
!           Loop variable
        , iv &
!           Loop variable (viewing level)
        , ie &
!           Loop variable
        , ls &
!           Polar order
        , lsr &
!           Reduced polar order
        , offset_u
!           Offset applied to the elements of u^+|- to move to
!           elements relevant to the current layer
      REAL  (RealK) :: &
          contribution &
!           Contribution of the current order to the flux
        , cnst_ls
!           Constant term involving the polar order
!
!     Subroutines called:
!      EXTERNAL &
!          eval_uplm
!
!
!
      IF (i_sph_algorithm == IP_sph_direct) THEN
!
!       Radiances or fluxes are calculated directly from the
!       spherical harmonics.
!
!       Determine the coefficients of the spherical harmonics
!       from the solution of the eigenproblem.
        DO iv=1, n_viewing_level
          offset_u=2*n_red_eigensystem*(i_rad_layer(iv)-1)
          DO k=1, 2*n_red_eigensystem
            DO lsr=1, ls_trunc+1-ms
              DO l=1, n_profile
                c_ylm(l, iv, lsr)=c_ylm(l, iv, lsr) &
                  +weight_u(l, iv, lsr, k)*upm(l, k+offset_u)
              ENDDO
            ENDDO
          ENDDO
        ENDDO
!
        IF (i_sph_mode == IP_sph_mode_flux) THEN
!
!         Although this routine is called to increment radiances over
!         angular orders, when run to calculate fluxes it should
!         only be called once during each monochromatic calculation.
!
          DO iv=1, n_viewing_level
            DO l=1, n_profile
              contribution=c_ylm(l, iv, 2)*sqrt(pi/3.0e+00_RealK)
!             Upward flux:
              flux_total(l, 2*iv-1)=contribution
!             Downward flux:
              flux_total(l, 2*iv)=-contribution
            ENDDO
          ENDDO
          DO ls=0, ls_trunc, 2
            cnst_ls=2.0e+00_RealK*kappa(1, (ls+2)/2) &
              *sqrt(pi/3.0e+00_RealK)
            DO iv=1, n_viewing_level
              DO l=1, n_profile
                contribution=cnst_ls*c_ylm(l, iv, ls+1)
                flux_total(l, 2*iv-1) &
                  =flux_total(l, 2*iv-1)-contribution
                flux_total(l, 2*iv) &
                  =flux_total(l, 2*iv)-contribution
              ENDDO
            ENDDO
          ENDDO
!
          IF (isolir == IP_solar) THEN
            DO iv=1, n_viewing_level
              DO l=1, n_profile
                flux_direct(l, iv-1)=i_direct(l, iv-1)*mu_0(l)
                flux_total(l, 2*iv)=flux_total(l, 2*iv) &
                  +flux_direct(l, iv-1)
              ENDDO
            ENDDO
          ENDIF
!
        ELSE IF (i_sph_mode == IP_sph_mode_j) THEN
!
!         Although this routine is called to increment radiances over
!         angular orders, when run to calculate mean radiances it should
!         be called only once during each monochromatic calculation.
!
          DO iv=1, n_viewing_level
            DO l=1, n_profile
              j_radiance(l, iv)=c_ylm(l, iv, 2)*sqrt(4.0e+00_RealK*pi)
            ENDDO
          ENDDO
!
          IF (isolir == IP_solar) THEN
            DO iv=1, n_viewing_level
              DO l=1, n_profile
                j_radiance(l, iv)=j_radiance(l, iv) &
                  +i_direct(l, iv)
              ENDDO
            ENDDO
          ENDIF
!
        ELSE IF (i_sph_mode == IP_sph_mode_rad) THEN
!
!         Determine the radiances directly from the amplitudes of
!         the harmonics.
          DO id=1, n_direction
!
!           Add in the contributions on each viewing level. To improve
!           convergence of the alternating series the contribution
!           from the last term may be reduced in size.
            DO iv=1, n_viewing_level
              DO lsr=1, ls_trunc-ms
                DO l=1, n_profile
                  radiance(l, iv, id)=radiance(l, iv, id) &
                    +azim_factor(l, id)*c_ylm(l, iv, lsr) &
                    *up_lm(l, lsr, id)
                ENDDO
              ENDDO
              DO l=1, n_profile
                radiance(l, iv, id)=radiance(l, iv, id)+euler_factor &
                  *azim_factor(l, id)*c_ylm(l, iv, ls_trunc+1-ms) &
                  *up_lm(l, ls_trunc+1-ms, id)
              ENDDO
            ENDDO
!
          ENDDO
        ENDIF
!
      ELSE IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
!
        DO id=1, n_direction
          DO iv=1, n_viewing_level
            DO ie=1, n_equation
              DO l=1, n_profile
                radiance(l, iv, id)=radiance(l, iv, id) &
                  +azim_factor(l, id) &
                  *weight_u(l, iv, id, ie)*upm(l, ie)
              ENDDO
            ENDDO
          ENDDO
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE INCREMENT_RAD_CF
!+ Subroutines to read a Spectral File.
!
   
SUBROUTINE read_spectrum_90(file_spectral, Spectrum, ierr)
!
! 
! Description:
!   The file is opened with checks. Logical arrays are set.
!   The file is now read until a line beginning a block is found.
!   A routine is called to read the block which in turn calls
!   an appropriate subroutine depending on the type, sub-type
!   and version of the block.
!
! Current Owner of Code: J. M. Edwards
!
! History:
! Version   Date     Comment
! -------   ----     -------
! 2.0       12-04-95 New F90 version. (J. M. Edwards)
!
! Description of Code:
!   Fortran90.
!
!
! Modules used:
  USE realtype_rd
  USE continuum_pcf
  USE def_spectrum
  USE dimensions_spec_ucf
  USE def_std_io_icf
  USE gas_list_pcf
  USE scale_fnc_pcf
  USE aerosol_parametrization_pcf
  USE cloud_parametrization_pcf
  USE ice_cloud_parametrization_pcf
  USE error_pcf
!
!
!
  IMPLICIT NONE
!
!
! Dummy variables.
  CHARACTER (LEN=80), Intent(IN) :: file_spectral
!   Name of spectral file
  INTEGER, Intent(INOUT) :: ierr
!   Error flag
  TYPE (StrSpecData), Target :: Spectrum
!   Spectral data
!
!
! Local variables.
  CHARACTER (LEN=80) :: line
!   Line read from file
  CHARACTER (LEN=80) :: char_dum
!   Dummy charcater variable
  INTEGER :: iu_spc
!   Unit number for I/O of the spectral file
  INTEGER :: ios
!   I/O error status
  INTEGER :: i_type
!   Type of block read in
  INTEGER :: i_subtype
!   Subtype of block
  INTEGER :: i_version
!   Version for type and subtype
  INTEGER :: i
!   Loop variable
  LOGICAL :: l_exist
!   Existence flag for file
!
! Pointers to dimensions: used to shorten declarations later
  INTEGER, Pointer :: nd_band
!   Size allocated for spectral bands
  INTEGER, Pointer :: nd_exclude
!   Size allocated for excluded bands
  INTEGER, Pointer :: nd_k_term
!   Size allocated for k-terms
  INTEGER, Pointer :: nd_species
!   Size allocated for gaseous species
  INTEGER, Pointer :: nd_scale_variable
!   Size allocated for scaling variables
  INTEGER, Pointer :: nd_continuum
!   Size allocated for continua
  INTEGER, Pointer :: nd_drop_type
!   Size allocated for drop types
  INTEGER, Pointer :: nd_ice_type
!   Size allocated for ice crystal types
  INTEGER, Pointer :: nd_aerosol_species
!   Size allocated for aerosol species
  INTEGER, Pointer :: nd_thermal_coeff
!   Size allocated for thermal coefficients
  INTEGER, Pointer :: nd_cloud_parameter
!   Size allocated for cloud parameters
  INTEGER, Pointer :: nd_humidity
!   Size allocated for humidities
  INTEGER, Pointer :: nd_phase_term
!   Size allocated for terms in the phase function
!
!
!
! Alias pointers to dimensions to the actual structure.
  nd_band            => Spectrum%Dim%nd_band
  nd_exclude         => Spectrum%Dim%nd_exclude
  nd_k_term          => Spectrum%Dim%nd_k_term
  nd_species         => Spectrum%Dim%nd_species
  nd_scale_variable  => Spectrum%Dim%nd_scale_variable
  nd_continuum       => Spectrum%Dim%nd_continuum
  nd_drop_type       => Spectrum%Dim%nd_drop_type
  nd_ice_type        => Spectrum%Dim%nd_ice_type
  nd_aerosol_species => Spectrum%Dim%nd_aerosol_species
  nd_thermal_coeff   => Spectrum%Dim%nd_thermal_coeff
  nd_cloud_parameter => Spectrum%Dim%nd_cloud_parameter
  nd_humidity        => Spectrum%Dim%nd_humidity
  nd_phase_term      => Spectrum%Dim%nd_phase_term
!
! Define array sizes. These cannot at present conveniently be inferred
! from the spectral file: eventually these should all be determined
! from a block of dimensions or by other dynamic means.
  nd_k_term = npd_k_term
  nd_scale_variable = npd_scale_variable
  nd_continuum = npd_continuum
  nd_drop_type = npd_drop_type
  nd_ice_type  = npd_ice_type
  nd_cloud_parameter  = npd_cloud_parameter
  nd_humidity  = npd_humidities
!
! It is important to know which gas is water vapour for some
! applications: here we initialize INDEX_WATER to 0 to
! produce an error in the code if it is not reset to a legal value.
! This should guard against omitting water vapour when it is needed.
  Spectrum%Cont%index_water=0
!
! Initialization of logical variables.
  Spectrum%Basic%l_present     = .FALSE.
!
! Check that the spectral file exists.
  INQUIRE(FILE=file_spectral, EXIST=l_exist)
  IF (.NOT.l_exist) THEN
    WRITE(iu_err, '(/a)') '*** Error: Spectral file does not exist.'
    ierr=i_err_exist
    RETURN
  ENDIF
!
! Get a unit to read the file.
  CALL get_free_unit(ierr, iu_spc)
  IF (ierr /= i_normal) RETURN
!
! Open the file for reading
  OPEN(UNIT=iu_spc, FILE=file_spectral, IOSTAT=ios, STATUS='OLD')
  IF (ios /= 0) THEN
    WRITE(iu_err, '(/a)') &
      '*** Error: Spectral file could not be opened.'
    ierr=i_err_fatal
    RETURN
  ENDIF
!
!
!
! Read through the file processing the blocks of data as they
! are encountered.
! Each line is read into an internal file and then processed.
  DO
    READ(iu_spc, '(a80)', IOSTAT=ios) line
!
    IF (ios /= 0) EXIT
!
!   Locate a block header.
    IF (line(1:6) == '*BLOCK') THEN
      READ(line, fmt='(a15, i4, 12x, i4, 12x, i4)', iostat=ios) &
        char_dum, i_type, i_subtype, i_version
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a/)') &
          '*** Error: Block header in spectrum is incorrect.'
        ierr=i_err_fatal
        RETURN
      ENDIF
!
!     Read in the rest of the block.
      CALL read_block_int
      IF (ierr /= i_normal) return
!
!     Read in the termination statement
      READ(iu_spc, '(a4)') char_dum
      IF (char_dum(1:4) /= '*END') THEN
        WRITE(iu_err, '(/a/)') &
          '*** Error: spectral block is incorrectly terminated:'
        WRITE(iu_err, '(2x, a7, i5, a13, i5, a12, i5)') &
          'Type = ', i_type, &
          ': Sub-type = ', i_subtype, &
          ': Version = ', i_version
        ierr=i_err_fatal
        RETURN
      ENDIF
!
!     The block has been properly read: record the data as present.
      Spectrum%Basic%l_present(i_type)= .TRUE. 
!
    ENDIF
!
  ENDDO
!
  CLOSE(iu_spc)
!
! Set the index of water.
  DO i=1, Spectrum%Gas%n_absorb
    IF (Spectrum%Gas%type_absorb(i) == ip_h2o) Spectrum%Cont%index_water=i
  ENDDO
!
! Deference pointers to dimensions.
  NULLIFY(nd_band)
  NULLIFY(nd_exclude)
  NULLIFY(nd_k_term)
  NULLIFY(nd_species)
  NULLIFY(nd_scale_variable)
  NULLIFY(nd_continuum)
  NULLIFY(nd_drop_type)
  NULLIFY(nd_ice_type)
  NULLIFY(nd_aerosol_species)
  NULLIFY(nd_thermal_coeff)
  NULLIFY(nd_cloud_parameter)
  NULLIFY(nd_humidity)
  NULLIFY(nd_phase_term)
!
!
!
  RETURN
!
!
CONTAINS
!
!
   
  SUBROUTINE read_block_int
!
!   Local variables
    LOGICAL :: l_block_read
!     Flag for correctly read block
    CHARACTER (LEN=80) :: line_temp
!     Temporary string to hold the current line
!     (this is only temporary: old spectral files should be processed
!     thoroughly eventually)
!
!
!   Start from the position that the block has not been read, then
!   use the flag to check for errors.
    l_block_read= .FALSE. 
!
!   Depending on the value of I_TYPE, the appropriate subroutine
!   is called.
    IF (i_type == 0) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 1) THEN
          CALL read_block_0_0_1_int
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 1) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_1_0_0_int
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 2) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_2_0_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 3) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_3_0_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 4) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_4_0_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 5) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_5_0_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 6) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_6_0_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 7) THEN
      WRITE(iu_err, '(/a, /a, /a)') &
        '*** Warning: Obsolete block.', &
        'Surface characteristics must be ' // &
        'specified using a .surf file:', &
        'this block will be ignored.'
    ELSE IF (i_type == 8) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_8_0_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 9) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_9_0_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 10) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_10_0_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
!
        ELSE IF (i_version == 1) THEN
!
          CALL read_block_10_0_1_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
!
!
        ELSE IF (i_version == 2) THEN
!
          CALL read_block_10_0_2_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
!
        ENDIF
      ENDIF
    ELSE IF (i_type == 11) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 1) THEN
          CALL read_block_11_0_1_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ELSE IF (i_version == 2) THEN
          CALL read_block_11_0_2_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ELSE IF (i_subtype == 1) THEN
        IF (i_version == 0) THEN
          CALL read_block_11_1_0_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ELSE IF (i_version == 1) THEN
          CALL read_block_11_1_1_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ELSE IF (i_version == 2) THEN
          CALL read_block_11_1_2_int
          IF (ierr /= i_normal) return
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 12) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_12_0_0_int
          l_block_read= .TRUE. 
        ELSE IF (i_version == 1) THEN
          CALL read_block_12_0_1_int
          l_block_read= .TRUE. 
        ELSE IF (i_version == 2) THEN
          CALL read_block_12_0_2_int
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ELSE IF (i_type == 14) THEN
      IF (i_subtype == 0) THEN
        IF (i_version == 0) THEN
          CALL read_block_14_0_0_int
          l_block_read= .TRUE. 
        ENDIF
      ENDIF
    ENDIF
!
    IF (ierr /= i_normal) THEN
      l_block_read = .FALSE.
      RETURN
    ENDIF
!
    IF (.NOT.l_block_read) THEN
!     This block is not of a supported type.
      WRITE(iu_err, '(/a, /, 3(3x, a, t15, a3, i3, /))') &
        '*** Warning: This sort of block is not permitted.', &
        'Type', ' = ', i_type, &
        'Subtype', ' = ', i_subtype, &
        'Version', ' = ', i_version
!     Read through to the end of the block.
      DO 
        READ(iu_spc, '(a)') line_temp
        IF (line_temp(1:4) == '*END') THEN
          BACKSPACE(iu_spc)
          EXIT
        ENDIF
      ENDDO
      RETURN
    ENDIF
!
!
!
  END SUBROUTINE read_block_int
!
!
!
   
  SUBROUTINE read_block_0_0_1_int
!
!
!
!   Local variables.
    CHARACTER :: chdum
!     Dummy character
    INTEGER :: idum
!     Dummy integer
!
!
!
!   Skip over the header.
    READ(iu_spc, *)
!
!   Read in the number of spectral intervals, the number of
!   gaseous absorbers and the number of aerosols.
    READ(iu_spc, '(27x, i5)', iostat=ios) Spectrum%Basic%n_band
    IF (ios /= 0) THEN
      WRITE(iu_err, '(/a/)') &
        '*** Error in subroutine read_block_0_0_1'
      WRITE(iu_err, *) 'Number of bands could not be read.'
      ierr=i_err_fatal
      RETURN
    ENDIF
    nd_band=Spectrum%Basic%n_band
    ALLOCATE(Spectrum%Basic%n_band_exclude(nd_band))
!   This must be zeroed lest block 14 should not be present and 
!   the array be filled with random values.
    Spectrum%Basic%n_band_exclude(1:nd_band) = 0
!
    READ(iu_spc, '(36x, i5)', iostat=ios) Spectrum%Gas%n_absorb
    IF (ios /= 0) THEN
      WRITE(iu_err, '(/a/)') &
        '*** Error in subroutine read_block_0_0_1'
      WRITE(iu_err, *) 'Number of absorbers could not be read.'
      ierr=i_err_fatal
      RETURN
    ENDIF
    nd_species=Spectrum%Gas%n_absorb
!
    READ(iu_spc, '(27x, i5)', iostat=ios) Spectrum%Aerosol%n_aerosol
    IF (ios /= 0) THEN
      WRITE(iu_err, '(/a/)') &
        '*** Error in subroutine read_block_0_0_1'
      WRITE(iu_err, *) 'Number of aerosols could not be read.'
      ierr=i_err_fatal
      RETURN
    ENDIF
    nd_aerosol_species=Spectrum%Aerosol%n_aerosol
!
!
!   Read over the headers and the list of absorbers.
    ALLOCATE(Spectrum%Gas%type_absorb(nd_species))
    READ(iu_spc, '(/)')
    DO i=1, Spectrum%Gas%n_absorb
      READ(iu_spc, '(i5, 7x, i5, 7x, a)') &
        idum, Spectrum%Gas%type_absorb(i), chdum
    ENDDO
!
!   Read over the headers and the list of aerosols.
    ALLOCATE(Spectrum%Aerosol%type_aerosol(nd_aerosol_species))
    READ(iu_spc, '(/)')
    DO i=1, Spectrum%Aerosol%n_aerosol
      READ(iu_spc, '(i5, 7x, i5, 7x, a)') &
        idum, Spectrum%Aerosol%type_aerosol(i), chdum
    ENDDO
!
!
!
    RETURN
  END SUBROUTINE read_block_0_0_1_int
!
!
!
   
  SUBROUTINE read_block_1_0_0_int
!
!
!
!   Local variables.
    INTEGER :: idum
!     Dummy integer
!
!
!
!   Skip over the headers.
    READ(iu_spc, '(//)')
!
!   Read in the limits on the intervals in the spectrum
    ALLOCATE(Spectrum%Basic%wavelength_short(nd_band))
    ALLOCATE(Spectrum%Basic%wavelength_long(nd_band))
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, fmt='(i5, 7x, 1pe16.9, 4x, 1pe16.9)', iostat=ios) &
        idum, Spectrum%Basic%wavelength_short(i), &
              Spectrum%Basic%wavelength_long(i)
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a, /a)') &
          '*** Error in subroutine read_block_1_0_0.', &
          'Wavelength limits of bands could not be read.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
!
!
    RETURN
  END SUBROUTINE read_block_1_0_0_int
!
!
!
   
  SUBROUTINE read_block_2_0_0_int
!
!
!
!   Local variables.
    INTEGER :: idum
!     Dummy integer
!
!
!   Skip over the headers.
    READ(iu_spc, '(/)')
!
!   Read in the limits on the intervals in the spectrum
    ALLOCATE(Spectrum%Solar%solar_flux_band(nd_band))
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, fmt='(i5, 7x, 1pe16.9)', iostat=ios) &
        idum, Spectrum%Solar%solar_flux_band(i)
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: solar spectral data are not correct.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
!
!
!
    RETURN
  END SUBROUTINE read_block_2_0_0_int
!
!
!
   
  SUBROUTINE read_block_3_0_0_int
!
!
!
!   Local variables.
    INTEGER :: idum
!     Dummy integer
!
!
!   Skip over the headers.
    READ(iu_spc, '(//)')
!
!   Read in the limits on the intervals in the spectrum
    ALLOCATE(Spectrum%Rayleigh%rayleigh_coeff(nd_band))
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, fmt='(i5, 7x, 1pe16.9)', iostat=ios) &
        idum, Spectrum%Rayleigh%rayleigh_coeff(i)
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: rayleigh scattering data are not correct.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
!
!
!
    RETURN
  END SUBROUTINE read_block_3_0_0_int
!
!
!
   
  SUBROUTINE read_block_4_0_0_int
!
!
!
!   Local variables.
    INTEGER :: idum
!         Dummy integer
    INTEGER :: j
!         Loop variable
!
!
!   Skip over the headers.
    READ(iu_spc, '(////)')
!
!   Read in the list of absorbers in each band.
    ALLOCATE(Spectrum%Gas%n_band_absorb(nd_band))
    ALLOCATE(Spectrum%Gas%index_absorb(nd_species, nd_band))
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, fmt='(i5, 7x, i5)', iostat=ios) &
        idum, Spectrum%Gas%n_band_absorb(i)
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a/)') &
          '*** Error in subroutine read_block_4_0_0'
        WRITE(iu_err, *) 'The list of absorbers is not correct.'
        ierr=i_err_fatal
        RETURN
      ENDIF
      IF (Spectrum%Gas%n_band_absorb(i) > 0) THEN
        READ(iu_spc, '(5x, 4(2x, i3))') &
          ( Spectrum%Gas%index_absorb(j, i), &
            j=1, Spectrum%Gas%n_band_absorb(i) )
      ENDIF
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a/)') &
          '*** Error in subroutine read_block_4_0_0'
        WRITE(iu_err, *) 'The list of absorbers is not correct.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
!
!
!
    RETURN
  END SUBROUTINE read_block_4_0_0_int
!
!
!
   
  SUBROUTINE read_block_5_0_0_int
!
!
!
!   Local variables.
    INTEGER :: idum_band
!     Dummy integer
    INTEGER :: idum_species
!     Dummy integer
    INTEGER :: idum_scale
!     Dummy integer
    INTEGER :: idum_fnc
!     Dummy integer
    INTEGER :: number_term
!     Number of ESFT terms
    INTEGER :: j
!     Loop variable
    INTEGER :: k
!     Loop variable
    INTEGER :: l
!     Loop variable
!
!
!
!   Allocate space for the arrays of k-terms.
    ALLOCATE(Spectrum%Gas%i_band_k(nd_band, nd_species))
    ALLOCATE(Spectrum%Gas%i_scale_k(nd_band, nd_species))
    ALLOCATE(Spectrum%Gas%i_scale_fnc(nd_band, nd_species))
    ALLOCATE(Spectrum%Gas%k(nd_k_term, nd_band, nd_species))
    ALLOCATE(Spectrum%Gas%w(nd_k_term, nd_band, nd_species))
    ALLOCATE(Spectrum%Gas%p_ref(nd_species, nd_band))
    ALLOCATE(Spectrum%Gas%t_ref(nd_species, nd_band))
    ALLOCATE(Spectrum%Gas%scale(nd_scale_variable, nd_k_term, &
      nd_band, nd_species))
!
!   Skip over the headers.
    READ(iu_spc, '(///)')
!
!   Read in the number of k-terms in each band.
    DO i=1, Spectrum%Basic%n_band
      DO j=1, Spectrum%Gas%n_band_absorb(i)
        READ(iu_spc, fmt='(i5, 5(7x, i5))', iostat=ios) &
          idum_band, idum_species, number_term, idum_scale, idum_fnc
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_5_0_0', &
            'k-distribution data are not consistent with the summary.'
          ierr=i_err_fatal
          RETURN
        ENDIF
        IF ( (idum_fnc /= IP_scale_power_law)    .AND. &
             (idum_fnc /= IP_scale_power_quad)   .AND. &
             (idum_fnc /= IP_scale_doppler_quad) .AND. &
             (idum_fnc /= IP_scale_fnc_null) ) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_5_0_0', &
            'an illegal scaling function has been specified.'
          ierr=i_err_fatal
          RETURN
        ENDIF
        IF (number_term > nd_k_term) THEN
          WRITE(iu_err, '(/a, /a, /a)') &
            '*** Error in subroutine read_block_5_0_0', &
            'Too many esft terms have been given.', &
            'increase NPD_k_term and recompile.'
            ierr=i_err_fatal
          RETURN
        ENDIF
        Spectrum%Gas%i_band_k(idum_band, idum_species)=number_term
        Spectrum%Gas%i_scale_k(idum_band, idum_species)=idum_scale
        Spectrum%Gas%i_scale_fnc(idum_band, idum_species)=idum_fnc
!
!       Read the reference temperature and pressure.
        READ(iu_spc, '(2(6x, 1pe16.9))') &
          Spectrum%Gas%p_ref(idum_species, idum_band), &
          Spectrum%Gas%t_ref(idum_species, idum_band)
!       For each band read in the k-terms and weights.
        DO k=1, number_term
          READ(iu_spc, '(2(3x, 1pe16.9), (t39,2(3x, 1pe16.9)))' &
            , iostat=ios) &
              Spectrum%Gas%k(k, idum_band, idum_species), &
              Spectrum%Gas%w(k, idum_band, idum_species), &
              (Spectrum%Gas%scale(l, k, idum_band, idum_species), &
              l=1, n_scale_variable(idum_fnc))
          IF (ios /= 0) THEN
            WRITE(iu_err, '(/a, /a)') &
              '*** Error in subroutine read_block_5_0_0', &
              'k-distribution data are not consistent with the summary.'
            ierr=i_err_fatal
            RETURN
          ENDIF
        ENDDO
      ENDDO
    ENDDO
!
!
!
    RETURN
  END SUBROUTINE read_block_5_0_0_int
!
!
!
   
  SUBROUTINE read_block_6_0_0_int
!
!
!
!   Local variables.
    INTEGER :: k
!         Loop variable
    INTEGER :: i_band
!         Number of band
!
!
    READ(iu_spc, '(/, 23x, i5, 26x, 1pe16.9)') &
        Spectrum%Planck%n_deg_fit, Spectrum%Planck%t_ref_planck
    nd_thermal_coeff = Spectrum%Planck%n_deg_fit + 1
    ALLOCATE(Spectrum%Planck%thermal_coeff(0:nd_thermal_coeff-1, nd_band))
!
    READ(iu_spc, '(/)')
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, '(i5, 7x, (t13, 3(1pe16.9, 4x)))', iostat=ios) &
        i_band, (Spectrum%Planck%thermal_coeff(k, i), &
        k=0, Spectrum%Planck%n_deg_fit)
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a, /a)') &
          '*** Error in subroutine read_block_6_0_0', &
          'The data for the thermal source function could not be read.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
!
!
!
    RETURN
  END SUBROUTINE read_block_6_0_0_int
!
!
!
   
  SUBROUTINE read_block_8_0_0_int
!
!
!
!   Local variables.
    INTEGER :: idum
!         Dummy integer
    INTEGER :: j
!         Loop variable
!
!
!
!   Allocate the continuum arrays:
    ALLOCATE(Spectrum%Cont%n_band_continuum(nd_band))
    ALLOCATE(Spectrum%Cont%index_continuum(nd_band, nd_continuum))
!hmjb Initialize
    Spectrum%Cont%n_band_continuum = 0
    Spectrum%Cont%index_continuum = 0
!   Skip over the headers.
    READ(iu_spc, '(////)')
!
!   Read in the limits on the intervals in the spectrum
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, fmt='(i5, 7x, i5)', iostat=ios) &
        idum, Spectrum%Cont%n_band_continuum(i)
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a, /a)') &
          '*** Error in subroutine read_block_8_0_0', &
          'the list of continua is not correct.'
        ierr=i_err_fatal
        RETURN
      ENDIF
      IF (Spectrum%Cont%n_band_continuum(i) > nd_continuum) THEN
        WRITE(iu_err, '(/a, /a, /a)') &
          '*** Error in subroutine read_block_8_0_0', &
          'There are too many continua:', &
          'increase npd_continuum and recompile.'
        ierr=i_err_fatal
        RETURN
      ENDIF
      IF (Spectrum%Cont%n_band_continuum(i) > 0) THEN
        READ(iu_spc, '(5x, 4(2x, i3))') &
          ( Spectrum%Cont%index_continuum(i, j), &
            j=1, Spectrum%Cont%n_band_continuum(i) )
      ENDIF
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a, /a)') &
          '*** Error in subroutine read_block_8_0_0', &
          'the list of continua is not correct.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
!
!   Read in the indices of gases forming the continuum species.
    READ(iu_spc, '(/, 22x, i5)') Spectrum%Cont%index_water
!
!
!
    RETURN
  END SUBROUTINE read_block_8_0_0_int
!
!
!
   
  SUBROUTINE read_block_9_0_0_int
!
!
!
!   Local variables.
    INTEGER :: idum_band
!     Dummy integer
    INTEGER :: idum_continuum
!     Dummy integer
    INTEGER :: idum_fnc
!     Dummy integer
    INTEGER :: j
!     Loop variable
    INTEGER :: l
!     Loop variable
!
!
!
!   Allocate space for the variables.
    ALLOCATE(Spectrum%Cont%k_cont(nd_band, nd_continuum))
    ALLOCATE(Spectrum%Cont%i_scale_fnc_cont(nd_band, nd_continuum))
    ALLOCATE(Spectrum%Cont%scale_cont(nd_scale_variable, &
      nd_band, nd_continuum))
    ALLOCATE(Spectrum%Cont%t_ref_cont(nd_continuum, nd_band))
    ALLOCATE(Spectrum%Cont%p_ref_cont(nd_continuum, nd_band))
!hmjb Initialize
    Spectrum%Cont%k_cont = 0.0
    Spectrum%Cont%i_scale_fnc_cont = 0.0
    Spectrum%Cont%scale_cont = 0.0
    Spectrum%Cont%p_ref_cont = 0.0
!
!   Skip over the headers.
    READ(iu_spc, '(//)')
!
    DO i=1, Spectrum%Basic%n_band
      DO j=1, Spectrum%Cont%n_band_continuum(i)
        READ(iu_spc, fmt='(i5, 2(7x, i5))', iostat=ios) &
          idum_band, idum_continuum, idum_fnc
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_9_0_0', &
            'continua in band could not be read.'
          ierr=i_err_fatal
          RETURN
        ENDIF
        Spectrum%Cont%i_scale_fnc_cont(idum_band, idum_continuum)=idum_fnc
!       Read the reference temperature and pressure.
        READ(iu_spc, '(2(6x, 1pe16.9))') &
          Spectrum%Cont%p_ref_cont(idum_continuum, idum_band), &
          Spectrum%Cont%t_ref_cont(idum_continuum, idum_band)
!       For each band read the values of the coefficients.
        READ(iu_spc, '(6x, 1pe16.9, (t23, 2(6x, 1pe16.9)))', &
            iostat=ios) &
          Spectrum%Cont%k_cont(idum_band, idum_continuum), &
          (Spectrum%Cont%scale_cont(l, idum_band, idum_continuum), &
           l=1, n_scale_variable(idum_fnc))
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_9_0_0', &
            'continuum data could not be read.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ENDDO
!
!
!
    RETURN
  END SUBROUTINE read_block_9_0_0_int
!
!
!
   
  SUBROUTINE read_block_10_0_0_int
!
!
!
!   Local variables.
    INTEGER :: i_drop
!     Type of droplet
    INTEGER :: i_parametrization_drop
!     Dummy index of parameter scheme
    INTEGER :: n_parameter
!     Number of parameters
    INTEGER :: k
!     Loop variable
    INTEGER :: i_dummy
!     Dummy reading variable
!
!
!
!   Allocate storage for droplet data if entering this block for the
!   first time.
    IF ( .NOT. ASSOCIATED(Spectrum%Drop%l_drop_type) ) THEN
      ALLOCATE(Spectrum%Drop%l_drop_type(nd_drop_type))
      Spectrum%Drop%l_drop_type(1:nd_drop_type)=.FALSE.
      ALLOCATE(Spectrum%Drop%i_drop_parm(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_min_dim(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_max_dim(nd_drop_type))
      ALLOCATE(Spectrum%Drop%n_phf(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_list(nd_cloud_parameter, nd_band, &
        nd_drop_type))
    ENDIF
!
!   Read the headers.
    READ(iu_spc, '(/, 27x, i5, /, 34x, i5, 27x, i5)') &
      i_drop, i_parametrization_drop, i_dummy
    IF (i_drop > nd_drop_type) THEN
      WRITE(iu_err, '(/a, /a, /a)') &
        '*** Error in subroutine read_block_10_0_0', &
        'Indexing number of droplet exceeds maximum permitted value:', &
        'Increase npd_drop_type and recompile.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
    IF ( (i_parametrization_drop == IP_slingo_schrecker)  .OR. &
         (i_parametrization_drop == IP_ackerman_stephens) .OR. &
         (i_parametrization_drop == IP_drop_pade_2) ) THEN
!     Data are parametrized.
!
!
!     Coding for backward compatibility: default settings of 0
!     introduced.
      Spectrum%Drop%parm_min_dim(i_drop)=0.0_RealK
      Spectrum%Drop%parm_max_dim(i_drop)=0.0_RealK
!     Only a parametrization of the asymmetry can be accommodated.
      Spectrum%Drop%n_phf(i_drop)=1
!
!
      n_parameter=i_dummy
!
      DO i=1, Spectrum%Basic%n_band
        READ(iu_spc, fmt='(/, (4(4x, 1pe12.5)))', iostat=ios) &
          (Spectrum%Drop%parm_list(k, i, i_drop), &
           k=1, n_parameter)
!       For each band read the values of the parameters.
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_10_0_0', &
            'data for droplets are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ELSE
!     Illegal parametrization scheme encountered.
      WRITE(iu_err, '(/a, /a)') &
        '*** Error in subroutine read_block_10_0_0', &
        'an unknown parametrization scheme has been specified.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
!   Record the presence of the drop type and the index
!   of the parametrization
    Spectrum%Drop%l_drop_type(i_drop)= .TRUE. 
    Spectrum%Drop%i_drop_parm(i_drop)=i_parametrization_drop
!
!
!
    RETURN
  END SUBROUTINE read_block_10_0_0_int
!
!
!
   
  SUBROUTINE read_block_10_0_1_int
!
!
!
!   Local variables.
    INTEGER :: i_drop
!     Type of droplet
    INTEGER i_parametrization_drop
!     Dummy index of parameter scheme
    INTEGER n_parameter
!     Number of parameters
    INTEGER i
!     Loop variable
    INTEGER k
!     Loop variable
    INTEGER ios
!     I/O error flag
    INTEGER i_dummy
!     Dummy reading variable
!
!
!
!   Allocate storage for droplet data if entering this block for
!   the first time.
    IF ( .NOT. ASSOCIATED(Spectrum%Drop%l_drop_type) ) THEN
      ALLOCATE(Spectrum%Drop%l_drop_type(nd_drop_type))
      Spectrum%Drop%l_drop_type(1:nd_drop_type)=.FALSE.
      ALLOCATE(Spectrum%Drop%i_drop_parm(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_min_dim(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_max_dim(nd_drop_type))
      ALLOCATE(Spectrum%Drop%n_phf(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_list(nd_cloud_parameter, nd_band, &
        nd_drop_type))
    ENDIF
!
!   Read the headers.
    READ(iu_spc, '(/, 27x, i5, /, 34x, i5, 27x, i5)') &
      i_drop, i_parametrization_drop, i_dummy
    IF (i_drop > nd_drop_type) THEN
      WRITE(iu_err, '(/a, /a, /a)') &
        '*** Error in subroutine read_block_10_0_1', &
        'The indexing number of a droplet exceeds the '// &
        'maximum permitted value:', &
        'increase npd_drop_type and recompile.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
    IF ( (i_parametrization_drop == IP_slingo_schrecker)  .OR. &
         (i_parametrization_drop == IP_ackerman_stephens) .OR. &
         (i_parametrization_drop == IP_drop_pade_2) ) THEN
!     Data are parametrized.
!
!     Settings for backward compatibility:
!     Only a parametrization of the asymmetry can be accommodated.
      Spectrum%Drop%n_phf(i_drop)=1
!
      READ(iu_spc, '(39x, 1pe12.5, 4x, 1pe12.5)') &
        Spectrum%Drop%parm_min_dim(i_drop), &
        Spectrum%Drop%parm_max_dim(i_drop)
!
      n_parameter=i_dummy
!
      DO i=1, Spectrum%Basic%n_band
        READ(iu_spc, fmt='(/, (4(4x, 1pe12.5)))', iostat=ios) &
          (Spectrum%Drop%parm_list(k, i, i_drop), k=1, n_parameter)
!       For each band read the values of the parameters.
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_10_0_1', &
            'Data for droplets are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ELSE
!     Illegal parametrization scheme encountered.
      WRITE(iu_err, '(/a, /a)') &
        '*** Error in subroutine read_block_10_0_1', &
        'An unknown parametrization scheme has been specified.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
!   Record the presence of the drop type and the index
!   of the parametrization
    Spectrum%Drop%l_drop_type(i_drop)= .TRUE. 
    Spectrum%Drop%i_drop_parm(i_drop)=i_parametrization_drop
!
!
!
    RETURN
  END SUBROUTINE read_block_10_0_1_int
!
!
!
   
  SUBROUTINE read_block_10_0_2_int
!
!
!
!   Local variables.
    INTEGER :: i_drop
!     Type of droplet
    INTEGER i_parametrization_drop
!     Dummy index of parameter scheme
    INTEGER n_parameter
!     Number of parameters
    INTEGER i
!     Loop variable
    INTEGER k
!     Loop variable
    INTEGER ios
!     I/O error flag
    INTEGER i_dummy
!     Dummy reading variable
!
!
!
!   Allocate storage for droplet data if entering this block for
!   the first time.
    IF ( .NOT. ASSOCIATED(Spectrum%Drop%l_drop_type) ) THEN
      ALLOCATE(Spectrum%Drop%l_drop_type(nd_drop_type))
      Spectrum%Drop%l_drop_type(1:nd_drop_type)=.FALSE.
      ALLOCATE(Spectrum%Drop%i_drop_parm(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_min_dim(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_max_dim(nd_drop_type))
      ALLOCATE(Spectrum%Drop%n_phf(nd_drop_type))
      ALLOCATE(Spectrum%Drop%parm_list(nd_cloud_parameter, nd_band, &
        nd_drop_type))
    ENDIF
!
!   Read the headers.
    READ(iu_spc, '(/, 27x, i5, /, 34x, i5, 27x, i5)') &
      i_drop, i_parametrization_drop, i_dummy
    IF (i_drop > nd_drop_type) THEN
      WRITE(iu_err, '(/a, /a, /a)') &
        '*** Error in subroutine read_block_10_0_2', &
        'The indexing number of a droplet exceeds the '// &
        'maximum permitted value:', &
        'increase npd_drop_type and recompile.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
    IF ( (i_parametrization_drop == IP_slingo_schrecker)  .OR. &
         (i_parametrization_drop == IP_Slingo_Schr_PHF )  .OR. &
         (i_parametrization_drop == IP_ackerman_stephens) .OR. &
         (i_parametrization_drop == IP_drop_pade_2) ) THEN
!     Data are parametrized.
!
      READ(iu_spc, '(42x, i5)') Spectrum%Drop%n_phf(i_drop)
!
      READ(iu_spc, '(39x, 1pe12.5, 4x, 1pe12.5)') &
        Spectrum%Drop%parm_min_dim(i_drop), &
        Spectrum%Drop%parm_max_dim(i_drop)
!
      n_parameter=i_dummy
!
      DO i=1, Spectrum%Basic%n_band
        READ(iu_spc, fmt='(/, (4(4x, 1pe12.5)))', iostat=ios) &
          (Spectrum%Drop%parm_list(k, i, i_drop), k=1, n_parameter)
!       For each band read the values of the parameters.
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_10_0_2', &
            'Data for droplets are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ELSE
!     Illegal parametrization scheme encountered.
      WRITE(iu_err, '(/a, /a)') &
        '*** Error in subroutine read_block_10_0_2', &
        'An unknown parametrization scheme has been specified.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
!   Record the presence of the drop type and the index
!   of the parametrization
    Spectrum%Drop%l_drop_type(i_drop)= .TRUE. 
    Spectrum%Drop%i_drop_parm(i_drop)=i_parametrization_drop
!
!
!
    RETURN
  END SUBROUTINE read_block_10_0_2_int
!
!
!
   
  SUBROUTINE read_block_11_0_1_int
!
!
!
!   Local variables.
    INTEGER :: i_species
!         Index of species
    INTEGER :: idum
!         Dummy reading variable
!
!
!   Allocate space for aerosol data if entering this block for the
!   first time.
    IF ( .NOT. ASSOCIATED(Spectrum%Aerosol%l_aero_spec) ) THEN
      nd_phase_term=1
      ALLOCATE(Spectrum%Aerosol%l_aero_spec(nd_aerosol_species))
      Spectrum%Aerosol%l_aero_spec(1:nd_aerosol_species) = .FALSE. 
      ALLOCATE(Spectrum%Aerosol%i_aerosol_parm(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%nhumidity(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%humidities(nd_humidity, nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%n_aerosol_phf_term(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%abs(nd_humidity, nd_aerosol_species, nd_band))
      ALLOCATE(Spectrum%Aerosol%scat(nd_humidity, nd_aerosol_species, nd_band))
      ALLOCATE(Spectrum%Aerosol%phf_fnc(nd_humidity, nd_phase_term, &
        nd_aerosol_species, nd_band))
    ENDIF
    READ(iu_spc, '(/, 19x, i5, //)') i_species
!
!   Read in the scattering parameters for each band
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, *, iostat=ios) idum, &
       Spectrum%Aerosol%abs(1, i_species, i), &
       Spectrum%Aerosol%scat(1, i_species, i), &
       Spectrum%Aerosol%phf_fnc(1, 1, i_species, i)
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a/)') &
          '*** Error in subroutine read_block_11_0_1'
        WRITE(iu_err, '(a)') &
          'Dry aerosol scattering data are not in the correct format.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
    Spectrum%Aerosol%nhumidity(i_species)=0
    Spectrum%Aerosol%i_aerosol_parm(i_species)=IP_aerosol_param_dry
    Spectrum%Aerosol%n_aerosol_phf_term(i_species)=1
!
!   After sucessful reading the presence of this species is recorded.
    Spectrum%Aerosol%l_aero_spec(i_species)= .TRUE. 
!
!
!
    RETURN
  END SUBROUTINE read_block_11_0_1_int
!
!
!
   
  SUBROUTINE read_block_11_0_2_int
!
!
!
!   Local variables.
    INTEGER :: l
!     Loop variable
    INTEGER :: i_species
!     Index of species
    INTEGER :: idum
!     Dummy reading variable
!
!
!   Allocate space for aerosol data if entering 
!   this block for the first time.
    IF ( .NOT. ASSOCIATED(Spectrum%Aerosol%l_aero_spec) ) THEN
      ALLOCATE(Spectrum%Aerosol%l_aero_spec(nd_aerosol_species))
      Spectrum%Aerosol%l_aero_spec(1:nd_aerosol_species) = .FALSE. 
      ALLOCATE(Spectrum%Aerosol%i_aerosol_parm(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%nhumidity(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%n_aerosol_phf_term(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%humidities(nd_humidity, nd_aerosol_species))
    ENDIF
!
    READ(iu_spc, '(/, 19x, i5)') i_species
    READ(iu_spc, '(36x, i5, //)') &
      Spectrum%Aerosol%n_aerosol_phf_term(i_species)
!
    nd_phase_term=Spectrum%Aerosol%n_aerosol_phf_term(i_species)
    IF ( .NOT. ASSOCIATED(Spectrum%Aerosol%abs) ) THEN
      ALLOCATE(Spectrum%Aerosol%abs(nd_humidity, &
        nd_aerosol_species, nd_band))
      ALLOCATE(Spectrum%Aerosol%scat(nd_humidity, &
        nd_aerosol_species, nd_band))
      ALLOCATE(Spectrum%Aerosol%phf_fnc(nd_humidity, nd_phase_term, &
        nd_aerosol_species, nd_band))
    ENDIF
!
!   Read in the scattering parameters for each band
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, *, iostat=ios) idum, &
        Spectrum%Aerosol%abs(1, i_species, i), &
        Spectrum%Aerosol%scat(1, i_species, i), &
        (Spectrum%Aerosol%phf_fnc(1, l, i_species, i), &
         l=1, Spectrum%Aerosol%n_aerosol_phf_term(i_species))
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a/)') &
          '*** Error in subroutine read_block_11_0_2'
        WRITE(iu_err, '(a)') &
          'Dry aerosol scattering data are not in the correct format.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
    Spectrum%Aerosol%nhumidity(i_species)=0
    IF (Spectrum%Aerosol%n_aerosol_phf_term(i_species) == 1) THEN
      Spectrum%Aerosol%i_aerosol_parm(i_species)=IP_aerosol_param_dry
    ELSE IF (Spectrum%Aerosol%n_aerosol_phf_term(i_species) > 1) THEN
      Spectrum%Aerosol%i_aerosol_parm(i_species)=IP_aerosol_param_phf_dry
    ENDIF
!
!   After sucessful reading the presence of this species is recorded.
    Spectrum%Aerosol%l_aero_spec(i_species)= .TRUE. 
!
!
!
    RETURN
  END SUBROUTINE read_block_11_0_2_int
!
!
!
   
  SUBROUTINE read_block_11_1_0_int
!
!
!
!   Local variables.
    INTEGER :: k
!         Loop variable
    INTEGER :: i_component
!         Index of component
!
!
!
!   Allocate arrays for aerosols.
    nd_phase_term=1
    IF ( .NOT. ASSOCIATED(Spectrum%Aerosol%l_aero_spec) ) THEN
      ALLOCATE(Spectrum%Aerosol%l_aero_spec(nd_aerosol_species))
      Spectrum%Aerosol%l_aero_spec(1:nd_aerosol_species) = .FALSE. 
      ALLOCATE(Spectrum%Aerosol%i_aerosol_parm(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%n_aerosol_phf_term(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%nhumidity(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%humidities(nd_humidity,nd_aerosol_species))
    ENDIF
!
    READ(iu_spc, '(/, 19x, i5 )') i_component
    READ(iu_spc, '(28x, i3)') Spectrum%Aerosol%nhumidity(i_component)
!
!    nd_humidity=Spectrum%Aerosol%nhumidity(i_component)
!
    IF ( .NOT.  ASSOCIATED(Spectrum%Aerosol%abs) ) THEN
      ALLOCATE(Spectrum%Aerosol%abs(nd_humidity, nd_aerosol_species, &
        nd_band))
      ALLOCATE(Spectrum%Aerosol%scat(nd_humidity, nd_aerosol_species, &
        nd_band))
      ALLOCATE(Spectrum%Aerosol%phf_fnc(nd_humidity, nd_phase_term, &
        nd_aerosol_species, nd_band))
    ENDIF
!
!   Read in the scattering parameters for each band
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, '(//)')
      DO k=1, Spectrum%Aerosol%nhumidity(i_component)
        READ(iu_spc, *, iostat=ios) &
          Spectrum%Aerosol%humidities(k, i_component), &
          Spectrum%Aerosol%abs(k, i_component, i), &
          Spectrum%Aerosol%scat(k, i_component, i), &
          Spectrum%Aerosol%phf_fnc(k, 1, i_component, i)
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a/)') &
            '*** Error in subroutine read_block_11_1_0'
          WRITE(iu_err, '(a)') &
            'Moist aerosol scattering data are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ENDDO
!
    Spectrum%Aerosol%i_aerosol_parm(i_component)=IP_aerosol_param_moist
    Spectrum%Aerosol%n_aerosol_phf_term(i_component)=1
!
!   After suceesful reading the presence 
!   of this component is recorded.
    Spectrum%Aerosol%l_aero_spec(i_component)= .TRUE. 
!
!
!
    RETURN
  END SUBROUTINE read_block_11_1_0_int
!
!
!
   
  SUBROUTINE read_block_11_1_1_int
!
!
!
!   Local variables.
    INTEGER :: k
!     Loop variable
    INTEGER :: i_species
!     Index of component
!
!
    nd_phase_term=1
    IF ( .NOT. ASSOCIATED(Spectrum%Aerosol%l_aero_spec) ) THEN
      ALLOCATE(Spectrum%Aerosol%l_aero_spec(nd_aerosol_species))
      Spectrum%Aerosol%l_aero_spec(1:nd_aerosol_species) = .FALSE. 
      ALLOCATE(Spectrum%Aerosol%i_aerosol_parm(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%n_aerosol_phf_term(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%nhumidity(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%humidities(nd_humidity,nd_aerosol_species))
    ENDIF
!
    READ(iu_spc, '(/, 19x, i5 )') i_species
    READ(iu_spc, '(28x, i3)') Spectrum%Aerosol%nhumidity(i_species)
!
!    nd_humidity=Spectrum%Aerosol%nhumidity(i_species)
!
    IF ( .NOT. ASSOCIATED(Spectrum%Aerosol%abs) ) THEN
      ALLOCATE(Spectrum%Aerosol%abs(nd_humidity, nd_aerosol_species, &
        nd_band))
      ALLOCATE(Spectrum%Aerosol%scat(nd_humidity, nd_aerosol_species, &
        nd_band))
      ALLOCATE(Spectrum%Aerosol%phf_fnc(nd_humidity, nd_phase_term, &
        nd_aerosol_species, nd_band))
    ENDIF
!
!   Read in the scattering parameters for each band: only the
!   asymmetry is used here.
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, '(//)')
      DO k=1, Spectrum%Aerosol%nhumidity(i_species)
          READ(iu_spc, *, iostat=ios) &
            Spectrum%Aerosol%humidities(k, i_species), &
            Spectrum%Aerosol%abs(k, i_species, i), &
            Spectrum%Aerosol%scat(k, i_species, i), &
            Spectrum%Aerosol%phf_fnc(k, 1, i_species, i)
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a/)') &
            '*** Error in subroutine read_block_11_1_1'
          WRITE(iu_err, '(a)') &
            'Moist aerosol scattering data are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ENDDO
!
    Spectrum%Aerosol%i_aerosol_parm(i_species)=IP_aerosol_param_moist
    Spectrum%Aerosol%n_aerosol_phf_term(i_species)=1
!
!   After sucessful reading the presence of this species is specified.
    Spectrum%Aerosol%l_aero_spec(i_species)= .TRUE. 
!
!
!
    RETURN
  END SUBROUTINE read_block_11_1_1_int
!
!
!
   
  SUBROUTINE read_block_11_1_2_int
!
!
!
!   Local variables.
    INTEGER :: k
!     Loop variable
    INTEGER :: l
!     Loop variable
    INTEGER :: i_species
!     Index of component
!
!
!   Allocate space for aerosol arrays.
    IF ( .NOT. ASSOCIATED(Spectrum%Aerosol%l_aero_spec) ) THEN
      ALLOCATE(Spectrum%Aerosol%l_aero_spec(nd_aerosol_species))
      Spectrum%Aerosol%l_aero_spec(1:nd_aerosol_species) = .FALSE. 
      ALLOCATE(Spectrum%Aerosol%i_aerosol_parm(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%n_aerosol_phf_term(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%nhumidity(nd_aerosol_species))
      ALLOCATE(Spectrum%Aerosol%humidities(nd_humidity,nd_aerosol_species))
    ENDIF
!
    READ(iu_spc, '(/, 19x, i5 )') i_species
    READ(iu_spc, '(28x, i3)') Spectrum%Aerosol%nhumidity(i_species)
    READ(iu_spc, '(36x, i5)') Spectrum%Aerosol%n_aerosol_phf_term(i_species)
!
    IF ( .NOT. ASSOCIATED(Spectrum%Aerosol%abs) ) THEN
      ALLOCATE(Spectrum%Aerosol%abs(nd_humidity, nd_aerosol_species, &
        nd_band))
      ALLOCATE(Spectrum%Aerosol%scat(nd_humidity, nd_aerosol_species, &
        nd_band))
      ALLOCATE(Spectrum%Aerosol%phf_fnc(nd_humidity, nd_phase_term, &
        nd_aerosol_species, nd_band))
    ENDIF
!
!   Read in the scattering parameters for each band.
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, '(//)')
      DO k=1, Spectrum%Aerosol%nhumidity(i_species)
          READ(iu_spc, *, iostat=ios) &
            Spectrum%Aerosol%humidities(k, i_species), &
            Spectrum%Aerosol%abs(k, i_species, i), &
            Spectrum%Aerosol%scat(k, i_species, i), &
            (Spectrum%Aerosol%phf_fnc(k, l, i_species, i), &
             l=1, Spectrum%Aerosol%n_aerosol_phf_term(i_species))
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_11_1_2', &
            'Moist aerosol scattering data are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ENDDO
!
    IF (Spectrum%Aerosol%n_aerosol_phf_term(i_species) == 1) THEN
      Spectrum%Aerosol%i_aerosol_parm(i_species)=IP_aerosol_param_moist
    ELSE IF (Spectrum%Aerosol%n_aerosol_phf_term(i_species) > 1) THEN
      Spectrum%Aerosol%i_aerosol_parm(i_species)=IP_aerosol_param_phf_moist
    ENDIF
!
!   After sucessful reading the presence of this species is recorded.
    Spectrum%Aerosol%l_aero_spec(i_species)= .TRUE. 
!
!
!
    RETURN
  END SUBROUTINE read_block_11_1_2_int
!
!
!
   
  SUBROUTINE read_block_12_0_0_int
!
!
!
!   Local variables.
    INTEGER :: i_ice
!         Type of ice crystal
    INTEGER :: i_parametrization_ice
!         Dummy index of parameter scheme
    INTEGER :: n_parameter
!         Number of parameters
    INTEGER :: k
!         Loop variable
    INTEGER :: i_dummy
!         Dummy reading variable
!
!
!
!   Allocate storage for ice data.
    IF ( .NOT. ASSOCIATED(Spectrum%Ice%l_ice_type) ) THEN
      ALLOCATE(Spectrum%Ice%l_ice_type(nd_ice_type))
      Spectrum%Ice%l_ice_type(1:nd_ice_type)=.FALSE.
      ALLOCATE(Spectrum%Ice%i_ice_parm(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_min_dim(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_max_dim(nd_ice_type))
      ALLOCATE(Spectrum%Ice%n_phf(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_list(nd_cloud_parameter, nd_band, &
        nd_ice_type))
    ENDIF
!
!   Read the headers.
    READ(iu_spc, '(/, 31x, i5, /, 34x, i5, 27x, i5)') &
      i_ice, i_parametrization_ice, i_dummy
    IF (i_ice > nd_ice_type) THEN
      WRITE(iu_err, '(/a, /a, /a)') &
        '*** Error in subroutine read_block_12_0_0', &
        'Type of ice crystal exceeds maximum permitted value:', &
        'Increase npd_ice_type and recompile.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
    IF ( (i_parametrization_ice == IP_slingo_schrecker_ice) .OR. &
         (i_parametrization_ice == IP_ice_adt)              .OR. &
         (i_parametrization_ice == IP_ice_adt_10)           .OR. &
         (i_parametrization_ice == IP_ice_fu_solar)         .OR. &
         (i_parametrization_ice == IP_ice_fu_ir)            .OR. &
         (i_parametrization_ice == IP_sun_shine_vn2_vis)    .OR. &
         (i_parametrization_ice == IP_sun_shine_vn2_ir) ) THEN
!     Data are parametrized.
      n_parameter=i_dummy
!
!
!     Code for backward compatibility: set the range of validity
!     of the parametrization to 0 to flag an unset range.
      Spectrum%Ice%parm_min_dim(i_ice)=0.0_RealK
      Spectrum%Ice%parm_max_dim(i_ice)=0.0_RealK
!     Only one moment of the asymmetry can be accommodated here.
      Spectrum%Ice%n_phf(i_ice)=1
!
!
      DO i=1, Spectrum%Basic%n_band
        READ(iu_spc, '()')
        READ(iu_spc, *, iostat=ios) &
          (Spectrum%Ice%parm_list(k, i, i_ice), k=1, n_parameter)
!       For each band read the values of the parameters.
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a, /a)') &
            '*** Error in subroutine read_block_12_0_0', &
            'Data for ice crystals are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ELSE
!     Illegal parametrization scheme encountered.
      WRITE(iu_err, '(/a, /a)') &
        '*** error in subroutine read_block_12_0_0', &
        'An unknown parametrization scheme has been specified.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
!   Record the presence of the ice crystal type and the index
!   of the parametrization
    Spectrum%Ice%l_ice_type(i_ice)= .TRUE. 
    Spectrum%Ice%i_ice_parm(i_ice)=i_parametrization_ice
!
!
!
    RETURN
  END SUBROUTINE read_block_12_0_0_int
!
!
!
   
  SUBROUTINE read_block_12_0_1_int
!
!
!
!   Local variables.
    INTEGER :: i_ice
!     Type of ice crystal
    INTEGER :: i_parametrization_ice
!     Dummy index of parameter scheme
    INTEGER :: n_parameter
!     Number of parameters
    INTEGER :: i_dummy
!     Dummy reading variable
!
!
!
!   Allocate storage for ice data.
    IF ( .NOT. ASSOCIATED(Spectrum%Ice%l_ice_type) ) THEN
      ALLOCATE(Spectrum%Ice%l_ice_type(nd_ice_type))
      Spectrum%Ice%l_ice_type(1:nd_ice_type)=.FALSE.
      ALLOCATE(Spectrum%Ice%i_ice_parm(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_min_dim(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_max_dim(nd_ice_type))
      ALLOCATE(Spectrum%Ice%n_phf(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_list(nd_cloud_parameter, nd_band, &
        nd_ice_type))
    ENDIF
!
!   Read the headers.
    READ(iu_spc, '(/, 31x, i5, /, 34x, i5, 27x, i5)') &
      i_ice, i_parametrization_ice, i_dummy
    IF (i_ice > nd_ice_type) THEN
      WRITE(iu_err, '(/a, /a, /a)') &
        '*** Error in subroutine read_block_12_0_1', &
        'The indexing number of an ice crystal ' // &
        'exceeds the maximum permitted value:', &
        'Increase npd_ice_type and recompile.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
    IF ( (i_parametrization_ice == IP_slingo_schrecker_ice) .OR. &
         (i_parametrization_ice == IP_ice_adt)              .OR. &
         (i_parametrization_ice == IP_ice_adt_10)           .OR. &
         (i_parametrization_ice == IP_ice_fu_solar)         .OR. &
         (i_parametrization_ice == IP_ice_fu_ir)            .OR. &
         (i_parametrization_ice == IP_sun_shine_vn2_vis)    .OR. &
         (i_parametrization_ice == IP_sun_shine_vn2_ir) ) THEN
!     Data are parametrized.
      n_parameter=i_dummy
!
!     Options for backward compatibility:
!     Only one moment of the asymmetry can be accommodated here.
      Spectrum%Ice%n_phf(i_ice)=1
!
      READ(iu_spc, '(39x, 1pe12.5, 4x, 1pe12.5)') &
        Spectrum%Ice%parm_min_dim(i_ice), &
        Spectrum%Ice%parm_max_dim(i_ice)
!
      DO i=1, Spectrum%Basic%n_band
        READ(iu_spc, '()')
        READ(iu_spc, *, iostat=ios) &
          Spectrum%Ice%parm_list(1:n_parameter, i, i_ice)
!       For each band read the values of the parameters.
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a/)') &
            '*** Error in subroutine read_block_12_0_1'
          WRITE(iu_err, *) &
            'Data for ice crystals are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ELSE
!     Illegal parametrization scheme encountered.
      WRITE(iu_err, '(/a)') &
        '*** Error in subroutine read_block_12_0_1'
      WRITE(iu_err, '(/a)') &
        'An unknown parametrization scheme has been specified.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
!   Record the presence of the ice crystal type and the index
!   of the parametrization
    Spectrum%Ice%l_ice_type(i_ice)= .TRUE. 
    Spectrum%Ice%i_ice_parm(i_ice)=i_parametrization_ice
!
!
!
    RETURN
  END SUBROUTINE read_block_12_0_1_int
!
!
!
   
  SUBROUTINE read_block_12_0_2_int
!
!
!
!   Local variables.
    INTEGER :: i_ice
!     Type of ice crystal
    INTEGER :: i_parametrization_ice
!     Dummy index of parameter scheme
    INTEGER :: n_parameter
!     Number of parameters
    INTEGER :: i_dummy
!     Dummy reading variable
!
!
!
!   Allocate storage for ice data.
    IF ( .NOT. ASSOCIATED(Spectrum%Ice%l_ice_type) ) THEN
      ALLOCATE(Spectrum%Ice%l_ice_type(nd_ice_type))
      Spectrum%Ice%l_ice_type(1:nd_ice_type)=.FALSE.
      ALLOCATE(Spectrum%Ice%i_ice_parm(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_min_dim(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_max_dim(nd_ice_type))
      ALLOCATE(Spectrum%Ice%n_phf(nd_ice_type))
      ALLOCATE(Spectrum%Ice%parm_list(nd_cloud_parameter, nd_band, &
        nd_ice_type))
    ENDIF
!
!   Read the headers.
    READ(iu_spc, '(/, 31x, i5, /, 34x, i5, 27x, i5)') &
      i_ice, i_parametrization_ice, i_dummy
    IF (i_ice > nd_ice_type) THEN
      WRITE(iu_err, '(/a, /a, /a)') &
        '*** Error in subroutine read_block_12_0_2', &
        'The indexing number of an ice crystal ' // &
        'exceeds the maximum permitted value:', &
        'Increase npd_ice_type and recompile.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
    IF ( (i_parametrization_ice == IP_slingo_schrecker_ice) .OR. &
         (i_parametrization_ice == IP_ice_adt)              .OR. &
         (i_parametrization_ice == IP_ice_adt_10)           .OR. &
         (i_parametrization_ice == IP_ice_fu_solar)         .OR. &
         (i_parametrization_ice == IP_ice_fu_ir)            .OR. &
         (i_parametrization_ice == IP_slingo_schr_ice_phf)  .OR. &
         (i_parametrization_ice == IP_ice_fu_phf)           .OR. &
         (i_parametrization_ice == IP_sun_shine_vn2_vis)    .OR. &
         (i_parametrization_ice == IP_sun_shine_vn2_ir) ) THEN
!     Data are parametrized.
      n_parameter=i_dummy
!
      READ(iu_spc, '(42x, i5)') Spectrum%Ice%n_phf(i_ice)
!
      READ(iu_spc, '(39x, 1pe12.5, 4x, 1pe12.5)') &
        Spectrum%Ice%parm_min_dim(i_ice), &
        Spectrum%Ice%parm_max_dim(i_ice)
!
      DO i=1, Spectrum%Basic%n_band
        READ(iu_spc, '()')
        READ(iu_spc, *, iostat=ios) &
          Spectrum%Ice%parm_list(1:n_parameter, i, i_ice)
!       For each band read the values of the parameters.
        IF (ios /= 0) THEN
          WRITE(iu_err, '(/a/)') &
            '*** Error in subroutine read_block_12_0_2'
          WRITE(iu_err, *) &
            'Data for ice crystals are not in the correct format.'
          ierr=i_err_fatal
          RETURN
        ENDIF
      ENDDO
    ELSE
!     Illegal parametrization scheme encountered.
      WRITE(iu_err, '(/a)') &
        '*** Error in subroutine read_block_12_0_2'
      WRITE(iu_err, '(/a)') &
        'An unknown parametrization scheme has been specified.'
      ierr=i_err_fatal
      RETURN
    ENDIF
!
!   Record the presence of the ice crystal type and the index
!   of the parametrization
    Spectrum%Ice%l_ice_type(i_ice)= .TRUE. 
    Spectrum%Ice%i_ice_parm(i_ice)=i_parametrization_ice
!
!
!
    RETURN
  END SUBROUTINE read_block_12_0_2_int
!
!
!
   
  SUBROUTINE read_block_14_0_0_int
!
!
!
!   Local variables.
    INTEGER :: idum
!     Dummy integer
    INTEGER :: j
!     Loop variable
!
!
!
!   Allocate space for arrys dealing with exclusions: n_band_exclude
!   has been allocated earlier.
    nd_exclude=npd_exclude
    ALLOCATE(Spectrum%Basic%index_exclude(nd_exclude, nd_band))
!   Skip over the headers.
    READ(iu_spc, '(//)')
!
!   Read in the list of excluded bands for each band in turn.
    DO i=1, Spectrum%Basic%n_band
      READ(iu_spc, fmt='(i5, 7x, i5)', iostat=ios) &
        idum, Spectrum%Basic%n_band_exclude(i)
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a/)') &
          '*** Error in subroutine read_block_14_0_0'
        WRITE(iu_err, *) &
          'The list of excluded bands is not correct.'
        ierr=i_err_fatal
        RETURN
      ENDIF
      IF (Spectrum%Basic%n_band_exclude(i) > 0) THEN
        READ(iu_spc, '(14x, 8(3x, i5))') &
          (Spectrum%Basic%index_exclude(j, i), &
           j=1, Spectrum%Basic%n_band_exclude(i) )
      ENDIF
      IF (ios /= 0) THEN
        WRITE(iu_err, '(/a/)') &
          '*** error in subroutine read_block_14_0_0'
        WRITE(iu_err, *) &
          'The list of excluded bands is not correct.'
        ierr=i_err_fatal
        RETURN
      ENDIF
    ENDDO
!
!
!
    RETURN
  END SUBROUTINE read_block_14_0_0_int
!
!
END SUBROUTINE read_spectrum_90
!
!+ Subroutine to calcaulate IR source function for differential flux.
!
! Method:
!        The linear contribution to the source function is proportional
!        to the absorption divided by the optical depth. A tolerance is
!        added to the optical depth to allow for the depth''s being 0.
!        A correction may also be made for a quadratic variation in the
!        temperature across the layer.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE ir_source(n_profile, i_layer_first, i_layer_last &
         , source_coeff, del_planck, l_ir_source_quad, diff_planck_2 &
         , s_down, s_up &
         , nd_profile, nd_layer, nd_source_coeff &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE source_coeff_pointer_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_source_coeff
!           Size allocated for source coefficients
!
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to consider
        , i_layer_last
!           Last layer to consider
!
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic representation
!
      REAL  (RealK), Intent(IN) :: &
          source_coeff(nd_profile, nd_layer, nd_source_coeff) &
!           Coefficients for source terms
        , del_planck(nd_profile, nd_layer) &
!           Difference in Planckian function across the layer
        , diff_planck_2(nd_profile, nd_layer)
!             2x2nd difference of Planckian
!
      REAL  (RealK), Intent(OUT) :: &
          s_down(nd_profile, nd_layer) &
!           Upward source function
        , s_up(nd_profile, nd_layer)
!           Upward source function
!
!
!     Local variables.
!
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!
!
!     Multiply the source coefficients by the Planckian differences
!     to the order required.
!
      IF (l_ir_source_quad) THEN
!
        DO i=1, nd_layer
          DO l=1, nd_profile
            s_up(l, i)=source_coeff(l, i, IP_scf_ir_1d) &
              *del_planck(l, i) &
              +source_coeff(l, i, IP_scf_ir_2d) &
              *diff_planck_2(l, i)
            s_down(l, i)=-source_coeff(l, i, IP_scf_ir_1d) &
              *del_planck(l, i) &
              +source_coeff(l, i, IP_scf_ir_2d) &
              *diff_planck_2(l, i)
          ENDDO
!
        ENDDO
!
      ELSE
!
        DO i=1, nd_layer
          DO l=1, nd_profile
            s_up(l, i)=source_coeff(l, i, IP_scf_ir_1d) &
              *del_planck(l, i)
            s_down(l, i)=-s_up(l, i)
          ENDDO
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE IR_SOURCE
!+ Subroutine to set the particular integral for one layer
!
! Purpose:
!   This routine calculates the particular integral in the
!   requested spectral region for the current layer.
!
! Method:
!
!   The solar particular integral is calculated using a recurrence,
!   while the particular integral in the infra-red is calculated
!   from the Planckian terms. A complementary function is added to
!   the naive form of the particular integral to maintain
!   numerical conditioning.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE layer_part_integ(&
!                        Basic sizes
          n_profile, ls_trunc, ms, n_red_eigensystem &
!                        Numerical arrays of spherical terms
        , cg_coeff, mu, eig_vec, theta &
!                        Solar variables
        , isolir, i_direct_top, mu_0, uplm_sol &
!                        Infra-red variables
        , diff_planck, l_ir_source_quad, diff_planck_2 &
!                        Optical properies
        , tau, sqs2 &
!                        Output variables
        , source_top, source_bottom, upm_c, k_sol, z_sol, q_0, q_1 &
!                        Dimensions
        , nd_profile, nd_max_order, nd_red_eigensystem &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_red_eigensystem
!           Size allocated for the reduced eigensystem
!
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric layers
        , n_red_eigensystem
!           Size of the reduced eigensystem
      INTEGER, Intent(IN) :: &
          ms &
!           Azimuthal order
        , ls_trunc
!           The truncating order of the system of equations
      INTEGER, Intent(IN) :: &
          isolir
!           Flag for spectral region
      REAL  (RealK), Intent(IN) :: &
          cg_coeff(ls_trunc+1-ms) &
!           Clebsch-Gordan coefficients
        , mu(nd_profile, nd_red_eigensystem) &
!           (Positive) Eigenvalues
        , eig_vec(nd_profile, 2*nd_red_eigensystem, nd_red_eigensystem) &
!           Eigenvectors of the full systems for positive eigenvalues
!           (these are scaled by the s-coefficients in the routine
!           EIG_SYS)
        , theta(nd_profile, nd_red_eigensystem)
!           Exponentials of optical depths along slant paths defined
!           by the eigenvalues
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile) &
!           Optical depths of the layers
        , sqs2(nd_profile, 0: nd_max_order)
!           S-coefficients
      REAL  (RealK), Intent(IN) :: &
          mu_0(nd_profile) &
!           Cosine of solar zenith angle
        , i_direct_top(nd_profile) &
!           The direct solar radiance at the top of the current layer
        , uplm_sol(nd_profile, ls_trunc+2-ms)
!           Spherical harmonics of the solar direction
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic source function in the IR
      REAL  (RealK), Intent(IN) :: &
          diff_planck(nd_profile) &
!           Differences in the hemispheric Planckian FLUX (bottom-top)
!           across the layer
        , diff_planck_2(nd_profile)
!           Twice the second differences in the hemispheric Planckian
!           FLUX
!
      INTEGER, Intent(OUT) :: &
          k_sol(nd_profile)
!           Index of eigenvalue used for solar conditioning
      REAL  (RealK), Intent(OUT) :: &
          source_top(nd_profile, ls_trunc+1-ms) &
!           Source function at the top of the layer
        , source_bottom(nd_profile, ls_trunc+1-ms) &
!           Source function at the bottom of the layer
        , z_sol(nd_profile, ls_trunc+1-ms) &
!           Coefficient of the solar particular integral
        , q_0(nd_profile) &
!           Term for thermal particular integral
        , q_1(nd_profile) &
!           Term for thermal particular integral
        , upm_c(nd_profile, 2*nd_red_eigensystem)
!           Arrays for coefficients of the complementary function
!           used to condition the particular integral
!
!
!     Local variables
      INTEGER &
          lsr &
!           Reduced polar order
        , k &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
        v_dif(nd_profile, ls_trunc+2-ms) &
!           Difference between particular integral and eigenvector
        , gamma(nd_profile) &
!           Constant used in the solar particular integral
        , x(nd_profile) &
!           Temporary variable
        , m1ls &
!           -1 raised to the power l+m
        , eig_sep(nd_profile) &
!           Separation of the eigenvalue from the cosine of the
!           solar zenith angle
        , eig_sep_tmp(nd_profile) &
!           Temporary version of the above used in searching
        , eig_diff &
!           Difference between eigenvalue and cosine of zenith angle
        , const
!           A ''working' constant
!
!
      upm_c=0.0

      IF (isolir == IP_solar) THEN
!
!       If an eigenvalue approaches the cosine of the zenith angle
!       the solution will become ill-conditioned. We reduce this
!       ill conditioning by subtracting a multiple of the
!       eigensolution with the eigenvalue closest to the cosine
!       of the zenith angle.
!
!       Fine the closest eigenvalue.
        DO l=1, n_profile
          k_sol(l)=1
          eig_sep(l)=abs(mu(l, 1)-mu_0(l))
        ENDDO
        DO k=1, n_red_eigensystem
          DO l=1, n_profile
            eig_sep_tmp(l)=abs(mu(l, k)-mu_0(l))
            IF (eig_sep_tmp(l) < eig_sep(l)) THEN
              k_sol(l)=k
              eig_sep(l)=eig_sep_tmp(l)
            ENDIF
          ENDDO
        ENDDO
!
!       Determine the particular integral for this layer.
!       Upward recurrence is stable here.
!
        DO l=1, n_profile
          v_dif(l, 1)=0.0E+00_RealK

          m1ls=REAL(1-2*mod(1, 2), RealK)

          v_dif(l, 2)=( -mu_0(L)*sqs2(l, ms)*v_dif(l, 1) &
                     + sqs2(l, ms)*m1ls*eig_vec(l,1,k_sol(l)) ) &
            /cg_coeff(1)
        ENDDO
!        
!       V_SOL is required one order beyond the truncation to
!       complete the solution.
!
        DO lsr=3, ls_trunc+2-ms
          DO l=1, n_profile
!        
            m1ls=REAL(1-2*mod(lsr-1, 2), RealK)

            v_dif(l, lsr) &
              =(-mu_0(l)*sqs2(l, lsr+ms-2)*v_dif(l, lsr-1) &
              -cg_coeff(lsr-2)*v_dif(l, lsr-2) &
              +sqs2(l, lsr+ms-2)*m1ls*eig_vec(l,lsr-1,k_sol(l))) &
              /cg_coeff(lsr-1)

          ENDDO
        ENDDO
        DO l=1, n_profile
          gamma(l)=uplm_sol(l, ls_trunc+2-ms)/v_dif(l, ls_trunc+2-ms)
        ENDDO
!
!       Set the solution to remove ill-conditioning. Note that the
!       first element of the eigenvector cannot be zero, since the
!       recurrence would then force all elements to be 0.
!        DO l=1, n_profile
!          upm_c(l, k_sol(l))=-i_direct_top(l)*gamma(l)
!     &      *v_sol(l, 1)/eig_vec(l, 1, k_sol(l))
!        ENDDO
!
!       Calculate the source function at the top and bottom
!       of this layer.
!
        DO lsr=1, ls_trunc+1-ms
          DO l=1, n_profile
!        
            z_sol(l, lsr)=i_direct_top(l) &
              *(gamma(l)*v_dif(l, lsr)-uplm_sol(l, lsr))

            source_top(l, lsr)=i_direct_top(l) &
              *(gamma(l)*v_dif(l, lsr)-uplm_sol(l, lsr))


            IF( eig_sep(l).lt.1.0e-06) THEN


              eig_diff=tau(l)/(mu_0(l)*mu(l,k_sol(l)))

              const = - gamma(l)*exp(-tau(l)/mu_0(l)) &
                      *( eig_diff+0.5*eig_diff**2 &
                      *(mu(l,k_sol(l))-mu_0(l)))

            ELSE

              eig_diff=tau(l)*(1.0/mu(l,k_sol(l))-1.0/mu_0(l))

              IF (eig_diff.lt.0.0 ) THEN

                 const=gamma(l)*exp(-tau(l)/mu(l,k_sol(l))) &
                      *(exp(eig_diff)-1.0) &
                      /(mu(l,k_sol(l))-mu_0(l))

              ELSE

                 const=gamma(l)*exp(-tau(l)/mu_0(l)) &
                      *(1.0-exp(-eig_diff)) &
                      /(mu(l,k_sol(l))-mu_0(l))

              ENDIF
            ENDIF

            m1ls=REAL(1-2*mod(lsr-1, 2), RealK)

            source_bottom(l, lsr) &
              = i_direct_top(l) * exp(-tau(l)/mu_0(l)) &
              *( gamma(l)*v_dif(l, lsr)-uplm_sol(l, lsr)) &
              + i_direct_top(l) *eig_vec(l, lsr, k_sol(l)) &
              *m1ls*const
          ENDDO
        ENDDO
!
      ELSE IF (isolir == IP_infra_red) THEN
!
!       The variation of the Planckian across the layer can be either
!       linear or quadratic in the optical depth. The particular
!       integrals tend to infinity as the optical depth tends to 0, so
!       a particular form of the complementary function must be added
!       to cancel off the singularity; otherwise ill-conditioning will
!       arise. Since the Planckian is azimuthally symmetric only terms
!       with m=0 are affected. Linear variations in the Planckian
!       produce a term in the particular integral with polar order 1.
!       More complicated variations produce terms at higher orders.
!       Note that ill-conditioning has been removed only in the case of
!       linear variations so far as the quadratic case is more
!       complicated. To deal with the case when TAU is 0, we add a
!       tolerance: it is therefore essential that Q_0 should be used
!       consistently to avoid errors in this limit.
!
        IF (ms == 0) THEN
!
          DO l=1, n_profile
            q_0(l)=sqrt(4.0e+00_RealK/(3.0e+00_realk*pi)) &
              *diff_planck(l)/(sqs2(l, 1)*tau(l)+epsilon(tau))
          ENDDO
!
          IF (l_ir_source_quad) THEN
!
            DO l=1, n_profile
              q_1(l)=2.0e+00_RealK &
                *sqrt(4.0e+00_RealK/(3.0e+00_realk*pi)) &
                *diff_planck_2(l)/(sqs2(l, 1)*tau(l)**2+epsilon(tau))
              source_top(l, 1) &
                =cg_coeff(1)*q_1(l)/sqs2(l, 0)
              source_bottom(l, 1)=source_top(l, 1)
              source_top(l, 2)=q_0(l)-0.5e+00_RealK*q_1(l)
              source_bottom(l, 2)=q_0(l)+0.5e+00_RealK*q_1(l)
            ENDDO
            IF (ls_trunc > 1) THEN
              DO l=1, n_profile
                source_top(l, 3)=cg_coeff(2)*q_1(l)/sqs2(l, 2)
                source_bottom(l, 3)=source_top(l, 3)
              ENDDO
            ENDIF
!
          ELSE
!
            DO l=1, n_profile
              source_top(l, 1)=0.0e+00_RealK
              source_bottom(l, 1)=0.0e+00_RealK
              source_top(l, 2)=q_0(l)
              source_bottom(l, 2)=source_top(l, 2)
            ENDDO
            IF (ls_trunc > 1) THEN
              DO l=1, n_profile
                source_top(l, 3)=0.0e+00_RealK
                source_bottom(l, 3)=0.0e+00_RealK
              ENDDO
            ENDIF
!
          ENDIF
!
!         Higher orders are unaffected.
          DO lsr=4, ls_trunc+1-ms
            DO l=1, n_profile
              source_top(l, lsr)=0.0e+00_RealK
              source_bottom(l, lsr)=0.0e+00_RealK
            ENDDO
          ENDDO
!
!         Now define the part of the complementary function to
!         restore conditioning.
          DO k=1, n_red_eigensystem
            DO l=1, n_profile
              upm_c(l, k+n_red_eigensystem) &
                =-q_0(l)*sqs2(l, 1)*eig_vec(l, 2, k)
              upm_c(l, k)=-upm_c(l, k+n_red_eigensystem)
            ENDDO
          ENDDO
!
!         We take advantage of the relationship between the formats
!         of the positive and negative exponentials to reduce the
!         number of operations.
          DO lsr=1, ls_trunc+1-ms
            m1ls=real(1-2*mod(lsr-1, 2), RealK)
            DO l=1, n_profile
              x(l)=upm_c(l, 1+n_red_eigensystem)*(theta(l, 1)-m1ls) &
                *eig_vec(l, lsr, 1)
            ENDDO
            DO k=2, n_red_eigensystem
              DO l=1, n_profile
                x(l)=x(l) &
                  +upm_c(l, k+n_red_eigensystem)*(theta(l, k)-m1ls) &
                  *eig_vec(l, lsr, k)
              ENDDO
            ENDDO
            DO l=1, n_profile
              source_top(l, lsr)=source_top(l, lsr)+x(l)
              source_bottom(l, lsr)=source_bottom(l, lsr)-m1ls*x(l)
            ENDDO
          ENDDO
!
        ELSE
!
!         This code should never be executed as non-zero azimuthal
!         orders are not relevant in the IR, but it is here for
!         safety.
          DO lsr=1, ls_trunc+1-ms
            DO l=1, n_profile
              source_top(l, lsr)=0.0e+00_RealK
              source_bottom(l, lsr)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDIF
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE LAYER_PART_INTEG
!+ Function to determine whether densities are required for clouds.
!
! Method:
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77 with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      FUNCTION l_cloud_density(n_condensed, i_phase_cmp, l_cloud_cmp &
         , i_condensed_param &
         , nd_cloud_component &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE cloud_parametrization_pcf
      USE ice_cloud_parametrization_pcf
      USE phase_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays
      INTEGER, Intent(IN) :: &
          nd_cloud_component
!           Size allocated for components of clouds
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_condensed &
!           Number of types of condensate
        , i_phase_cmp(nd_cloud_component) &
!           Phases of components
        , i_condensed_param(nd_cloud_component)
!           Parametrizations of components
      LOGICAL, Intent(IN) :: &
          l_cloud_cmp(nd_cloud_component)
!           Flags for enabled components
      LOGICAL :: &
          l_cloud_density
!           Returned flag for calculating density
!
!
!     Local variables.
      INTEGER &
          k
!           Loop variable
!
!
      l_cloud_density=.false.
!
!     Densities must be calculated if Sun & Shine''s parametrizations
!     are used.
      DO k=1, n_condensed
        l_cloud_density=l_cloud_density.OR. &
          (l_cloud_cmp(k).AND.(i_phase_cmp(k) == IP_phase_ice).and. &
          ( (i_condensed_param(k) == IP_sun_shine_vn2_vis).OR. &
            (i_condensed_param(k) == IP_sun_shine_vn2_ir) ) ) &

          .OR.( (i_phase_cmp(k) == IP_phase_water).AND. &
                  (i_condensed_param(k) == IP_drop_unparametrized)) &
          .OR.( (i_phase_cmp(k) == IP_phase_ice).AND. &
                  (i_condensed_param(k) == IP_ice_unparametrized))

      ENDDO
!
!
!
      RETURN
      END FUNCTION L_CLOUD_DENSITY
!+ Subroutine to solve for fluxes treating scattering approximately.
!
! Method:
!        The routine is applicable in the infra-red. downward
!        differential fluxes are calculated first assuming that the
!        upward differential fluxes are 0. Upward fluxes are then
!        calculated using the previously calculated downward fluxes
!        in the reflected terms.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! description of code:
!   fortran 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE mix_app_scat(n_profile, n_layer, n_cloud_top &
         , t_free, r_free, s_down_free, s_up_free &
         , t_cloud, r_cloud, s_down_cloud, s_up_cloud &
         , g_ff, g_fc, g_cf, g_cc &
         , b_ff, b_fc, b_cf, b_cc &
         , flux_inc_down &
         , source_ground, albedo_surface_diff &
         , flux_diffuse &
         , nd_profile, nd_layer, id_ct &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_ct
!           Topmost declared cloudy layer
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Topmost cloudy layer
      REAL  (RealK), Intent(IN) :: &
          t_free(nd_profile, nd_layer) &
!           Free transmission
        , r_free(nd_profile, nd_layer) &
!           Free reflection
        , s_down_free(nd_profile, nd_layer) &
!           Free downward source function
        , s_up_free(nd_profile, nd_layer) &
!           Free upward source function
        , t_cloud(nd_profile, nd_layer) &
!           Cloudy transmission
        , r_cloud(nd_profile, nd_layer) &
!           Cloudy reflection
        , s_down_cloud(nd_profile, nd_layer) &
!           Downward cloudy source function
        , s_up_cloud(nd_profile, nd_layer)
!           Upward cloudy source function
      REAL  (RealK), Intent(IN) :: &
          g_ff(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , g_fc(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , g_cf(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , g_cc(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , b_ff(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , b_fc(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , b_cf(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , b_cc(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient
      REAL  (RealK), Intent(IN) :: &
          flux_inc_down(nd_profile) &
!           Incident diffuse flux
        , source_ground(nd_profile) &
!           Source from ground
        , albedo_surface_diff(nd_profile)
!           Diffuse albedo
      REAL  (RealK), Intent(OUT) :: &
          flux_diffuse(nd_profile, 2*nd_layer+2)
!           Diffuse flux
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
      REAL  (RealK) :: &
          flux_down(nd_profile, 0: nd_layer) &
!           Downward fluxes outside clouds just below i''th level
        , flux_down_cloud(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below i''th level
        , flux_up(nd_profile, 0: nd_layer) &
!           Upward fluxes outside clouds just above i''th level
        , flux_up_cloud(nd_profile, 0: nd_layer) &
!           Upward fluxes inside clouds just above i''th level
        , flux_propagated &
!           Temporary propagated flux outside cloud
        , flux_propagated_cloud &
!           Temporary propagated flux inside cloud
        , flux_cloud_top(nd_profile)
!           Total downward flux at top of cloud
!
!
!
!     The arrays flux_down and flux_up will eventually contain the total
!     fluxes, but initially they are used for the clear fluxes.
!     Note that downward fluxes refer to values just below the interface
!     and upward fluxes to values just above it.
!
!
!     Downward flux:
!
!     Region above clouds:
      DO l=1, n_profile
        flux_down(l, 0)=flux_inc_down(l)
      ENDDO
      DO i=1, n_cloud_top-1
        DO l=1, n_profile
          flux_down(l, i)=t_free(l, i)*flux_down(l, i-1) &
            +s_down_free(l, i)
        ENDDO
      ENDDO
      DO l=1, n_profile
        flux_cloud_top(l)=flux_down(l, n_cloud_top-1)
      ENDDO
!
!     Region of clouds:
      DO l=1, n_profile
        flux_down(l, n_cloud_top-1) &
          =g_ff(l, n_cloud_top-1)*flux_cloud_top(l)
        flux_down_cloud(l, n_cloud_top-1) &
          =g_fc(l, n_cloud_top-1)*flux_cloud_top(l)
      ENDDO
!
      DO i=n_cloud_top, n_layer-1
        DO l=1, n_profile
!
!         Propagate downward fluxes through the layer.
          flux_propagated=t_free(l, i)*flux_down(l, i-1) &
            +s_down_free(l, i)
          flux_propagated_cloud=t_cloud(l, i)*flux_down_cloud(l, i-1) &
            +s_down_cloud(l, i)
!         Transfer downward fluxes across the interface.
          flux_down(l, i) &
            =g_ff(l, i)*flux_propagated &
            +g_cf(l, i)*flux_propagated_cloud
          flux_down_cloud(l, i) &
            =g_cc(l, i)*flux_propagated_cloud &
            +g_fc(l, i)*flux_propagated
!
        ENDDO
      ENDDO
!
!     Propagate across the bottom layer, but without transferring
!     across the surface and form the reflected beams.
      DO l=1, n_profile
!       Propagate downward fluxes through the layer.
        flux_down(l, n_layer) &
          =t_free(l, n_layer)*flux_down(l, n_layer-1) &
          +s_down_free(l, n_layer)
        flux_down_cloud(l, n_layer) &
          =t_cloud(l, n_layer)*flux_down_cloud(l, n_layer-1) &
          +s_down_cloud(l, n_layer)
        flux_up(l, n_layer) &
          =albedo_surface_diff(l)*flux_down(l, n_layer) &
          +b_ff(l, n_layer)*source_ground(l)
        flux_up_cloud(l, n_layer) &
          =albedo_surface_diff(l)*flux_down_cloud(l, n_layer) &
          +b_cf(l, n_layer)*source_ground(l)
      ENDDO
!
!
!     Calculate the upward fluxes using the previous downward fluxes
!     to approximate the scattering term.
      DO i=n_layer, n_cloud_top, -1
        DO l=1, n_profile
!
!         Propagate upward fluxes through the layer.
          flux_propagated=t_free(l, i)*flux_up(l, i)+s_up_free(l, i) &
            +r_free(l, i)*flux_down(l, i-1)
          flux_propagated_cloud=t_cloud(l, i)*flux_up_cloud(l, i) &
            +s_up_cloud(l, i)+r_cloud(l, i)*flux_down_cloud(l, i-1)
!         Transfer upward fluxes across the interface.
          flux_up(l, i-1)=b_ff(l, i-1)*flux_propagated &
            +b_fc(l, i-1)*flux_propagated_cloud
          flux_up_cloud(l, i-1)=b_cc(l, i-1)*flux_propagated_cloud &
            +b_cf(l, i-1)*flux_propagated
!
        ENDDO
      ENDDO
!
!     Continue through the region above clouds.
      DO i=n_cloud_top-1, 1, -1
        DO l=1, n_profile
          flux_up(l, i-1)=t_free(l, i)*flux_up(l,i)+s_up_free(l, i) &
            +r_free(l, i)*flux_down(l, i-1)
        ENDDO
      ENDDO
!
!
!
!     Calculate the overall flux.
      DO i=0, n_cloud_top-2
        DO l=1, n_profile
          flux_diffuse(l, 2*i+1)=flux_up(l, i)
          flux_diffuse(l, 2*i+2)=flux_down(l, i)
        ENDDO
      ENDDO
      DO i=n_cloud_top-1, n_layer
        DO l=1, n_profile
          flux_diffuse(l, 2*i+1)=flux_up(l, i)+flux_up_cloud(l, i)
          flux_diffuse(l, 2*i+2)=flux_down(l, i) &
            +flux_down_cloud(l, i)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE MIX_APP_SCAT
!+ Subroutine to solve the two-stream equations in a mixed column.
!
! Method:
!        The two-stream coefficients are calculated in clear regions
!        and in stratiform and convective clouds. From these
!        coefficients transmission and reflection coefficients are
!        determined. The coefficients for convective and stratiform
!        clouds are appropriately mixed to form single cloudy values
!        and an appropriate solver is called.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE mix_column(ierr &
!                        Atmospheric properties
         , n_profile, n_layer, k_clr &
!                        Two-stream scheme
         , i_2stream &
!                        Options for solver
         , i_solver &
!                        Options for equivalent extinction
         , l_scale_solar, adjust_solar_ke &
!                        Spectral region
         , isolir &
!                        Infra-red properties
         , diff_planck &
         , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
         , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                        Conditions at surface
         , diffuse_albedo, direct_albedo, d_planck_flux_surface &
!                       Optical Properties
         , ss_prop &
!                        Cloud geometry
         , n_cloud_top &
         , n_cloud_type, frac_cloud &
         , w_free, w_cloud &
         , cloud_overlap &
!                        Calculated fluxes
         , flux_direct, flux_total &
!                        Flags for clear-sky calculations
         , l_clear, i_solver_clear &
!                        Calculated clear-sky fluxes
         , flux_direct_clear, flux_total_clear &
!                        Dimensions of arrays
         , nd_profile, nd_layer, nd_layer_clr, id_ct &
         , nd_max_order, nd_source_coeff &
         , nd_cloud_type, nd_overlap_coeff &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE def_std_io_icf
      USE error_pcf
      USE solver_pcf
      USE spectral_region_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_layer_clr &
!           Size allocated for completely clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_source_coeff &
!           Size allocated for coefficients in the source function
        , nd_cloud_type &
!           Size allocated for types of clouds
        , nd_overlap_coeff
!           Size allocated for overlpa coefficients
!
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Top cloudy layer
        , k_clr &
!           Index of the clear-sky region
        , n_cloud_type &
!           Number of types of clouds
        , isolir &
!           Spectral region
        , i_2stream &
!           Two-stream scheme
        , i_solver &
!           Solver used
        , i_solver_clear
!           Solver for clear-sky fluxes
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      LOGICAL, Intent(IN) :: &
          l_clear &
!           Calculate clear-sky fluxes
        , l_scale_solar &
!           Flag to scale solar
        , l_ir_source_quad
!           Use quadratic source term
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!     Cloud geometry:
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy fractions in each layer
        , w_free(nd_profile, id_ct: nd_layer) &
!           Clear sky fractions in each layer
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of different types of cloud
        , cloud_overlap(nd_profile, id_ct-1: nd_layer &
            , nd_overlap_coeff)
!           Energy transfer coefficients
      REAL  (RealK), Intent(IN) :: &
          sec_00(nd_profile, nd_layer) &
!           Secant of solar zenith angle
        , diffuse_albedo(nd_profile) &
!           Diffuse albedo
        , direct_albedo(nd_profile) &
!           Direct albedo
        , flux_inc_down(nd_profile) &
!           Incident total flux
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , diff_planck(nd_profile, nd_layer) &
!           Change in Planckian function
        , d_planck_flux_surface(nd_profile) &
!           Flux from surface
        , adjust_solar_ke(nd_profile, nd_layer) &
!           Adjustment of solar beam with equivalent extinction
        , diff_planck_2(nd_profile, nd_layer)
!             2x2nd difference of Planckian
!
!     Fluxes calculated
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Direct flux
        , flux_total(nd_profile, 2*nd_layer+2) &
!           Long flux vector
        , flux_direct_clear(nd_profile, 0: nd_layer) &
!           Clear direct flux
        , flux_total_clear(nd_profile, 2*nd_layer+2)
!           Clear total flux
!
!
!
!     Local variabales.
      INTEGER &
          n_source_coeff &
!           Number of source coefficients
        , i &
!           Loop variable
        , l
!           Loop variable
!
!     Pointers to sections of the array of overlap coefficients:
!     Here F denotes the clear-sky region and C the cloudy region;
!     the ordering of the final suffix is such that the suffix for
!     the area being left appears last: this is convenient to agree
!     with the documented notation, but is not directly consistent
!     with older versions of the code.
      INTEGER &
          i_ovp_dn_ff &
!           Pointer to section of the array of overlaps for downward
!           transmission from clear-sky to clear-sky
        , i_ovp_dn_fc &
!           Pointer to section of the array of overlaps for downward
!           transmission from cloud to clear-sky
        , i_ovp_dn_cf &
!           Pointer to section of the array of overlaps for downward
!           transmission from clear-sky to cloud
        , i_ovp_dn_cc &
!           Pointer to section of the array of overlaps for downward
!           transmission from cloud to cloud
        , i_ovp_up_ff &
!           Pointer to section of the array of overlaps for upward
!           transmission from clear-sky to clear-sky
        , i_ovp_up_fc &
!           Pointer to section of the array of overlaps for upward
!           transmission from cloud to clear-sky
        , i_ovp_up_cf &
!           Pointer to section of the array of overlaps for upward
!           transmission from clear-sky to cloud
        , i_ovp_up_cc
!           Pointer to section of the array of overlaps for upward
!           transmission from cloud to cloud
!
!
!     Clear-sky coefficients:
      REAL  (RealK) :: &
          trans_free(nd_profile, nd_layer) &
!           Free transmission of layer
        , reflect_free(nd_profile, nd_layer) &
!           Free reflectance of layer
        , trans_0_free(nd_profile, nd_layer) &
!           Free direct transmission of layer
        , source_coeff_free(nd_profile, nd_layer, nd_source_coeff) &
!           Free source coefficients
        , s_down_free(nd_profile, nd_layer) &
!           Free downward source
        , s_up_free(nd_profile, nd_layer) &
!           Free upward source
        , s_down_clear(nd_profile, nd_layer) &
!           Clear downward source
        , s_up_clear(nd_profile, nd_layer)
!           Clear upward source
!
!     Cloudy coefficients:
      REAL  (RealK) :: &
          trans_cloud(nd_profile, nd_layer) &
!           Cloudy transmission of layer
        , reflect_cloud(nd_profile, nd_layer) &
!           Cloudy reflectance of layer
        , trans_0_cloud(nd_profile, nd_layer) &
!           Cloudy direct transmission of layer
        , source_coeff_cloud(nd_profile, nd_layer, nd_source_coeff) &
!           Cloudy source coefficients
        , s_down_cloud(nd_profile, nd_layer) &
!           Cloudy downward source
        , s_up_cloud(nd_profile, nd_layer)
!           Cloudy upward source
!
!     Source functions at the surface
      REAL  (RealK) :: &
          source_ground_free(nd_profile) &
!           Source from ground under clear skies
        , source_ground_cloud(nd_profile) &
!           Source from ground under cloudy skies
        , flux_direct_ground_cloud(nd_profile)
!           Direct flux at ground under cloudy skies
!
!!     Functions called:
!      INTEGER &
!          set_n_source_coeff
!!           Function to set number of source coefficients
!!
!!     Subroutines called:
!      EXTERNAL &
!          two_coeff, two_coeff_cloud, ir_source, mixed_solar_source &
!        , band_solver , mix_app_scat, clear_supplement
!
!
!
!     Set the pointers to the various types of transition.
      i_ovp_dn_ff=3*k_clr-2
      i_ovp_dn_fc=k_clr+1
      i_ovp_dn_cf=4-k_clr
      i_ovp_dn_cc=7-3*k_clr
      i_ovp_up_ff=4+i_ovp_dn_ff
      i_ovp_up_fc=4+i_ovp_dn_fc
      i_ovp_up_cf=4+i_ovp_dn_cf
      i_ovp_up_cc=4+i_ovp_dn_cc
!
!     Calculate the transmission and reflection coefficients and
!     source terms for the clear and cloudy parts of the column
!
!     Set the number of source coefficients for the approximation
      n_source_coeff=set_n_source_coeff(isolir, l_ir_source_quad)
!
!      CALL two_coeff(ierr &
!        , n_profile, 1, n_cloud_top-1 &
!        , i_2stream, l_ir_source_quad &
!        , ss_prop%phase_fnc_clr(:, :, 1) &
!        , ss_prop%omega_clr, ss_prop%tau_clr &
!        , isolir, sec_00 &
!        , trans_free, reflect_free, trans_0_free &
!        , source_coeff_free &
!        , nd_profile, 1, nd_layer_clr, 1, nd_layer, nd_source_coeff &
!        )
!      CALL two_coeff(ierr &
!        , n_profile, n_cloud_top, n_layer &
!        , i_2stream, l_ir_source_quad &
!        , ss_prop%phase_fnc(:, :, :, 0) &
!        , ss_prop%omega(:, :, 0), ss_prop%tau(:, :, 0) &
!        , isolir, sec_00 &
!        , trans_free, reflect_free, trans_0_free &
!        , source_coeff_free &
!        , nd_profile, id_ct, nd_layer, 1, nd_layer, nd_source_coeff &
!        )
      CALL two_coeff(ierr &
        , n_profile, 1, n_layer &
        , i_2stream, l_ir_source_quad &
        , ss_prop%phase_fnc(:, :, :, 0) &
        , ss_prop%omega(:, :, 0), ss_prop%tau(:, :, 0) &
        , isolir, sec_00 &
        , trans_free, reflect_free, trans_0_free &
        , source_coeff_free &
        , nd_profile, id_ct, nd_layer, 1, nd_layer, nd_source_coeff &
        )
      IF (ierr /= i_normal) RETURN
!
!
!     Infra-red source terms depend only on the layer and may be
!     calculated now. Solar terms depend on conditions in cloud
!     in overlying layers and must be calculated later.
!
      IF (isolir == IP_infra_red) THEN
!
        CALL ir_source(n_profile, 1, n_layer &
          , source_coeff_free, diff_planck &
          , l_ir_source_quad, diff_planck_2 &
          , s_down_free, s_up_free &
          , nd_profile, nd_layer, nd_source_coeff &
          )
!
!       If a clear-sky calculation is required these source terms must
!       be stored.
        IF (l_clear) THEN
          DO i=1, n_layer
            DO l=1, n_profile
              s_down_clear(l, i)=s_down_free(l, i)
              s_up_clear(l, i)=s_up_free(l, i)
            ENDDO
          ENDDO
        ENDIF
!
!       Scale the sources by the clear-sky fractions in the cloudy
!       layers. In higher layers the clear-sky fraction is 1.
        DO i=n_cloud_top, n_layer
          DO l=1, n_profile
            s_down_free(l, i)=w_free(l, i)*s_down_free(l, i)
            s_up_free(l, i)=w_free(l, i)*s_up_free(l, i)
          ENDDO
        ENDDO
!
      ENDIF
!
!
!
!     Repeat the calculation for cloudy regions.
!
!     Clouds are indexed beginning with index 1 in the last
!     dimension of arrays of optical properties.
!
!
      CALL two_coeff_cloud(ierr &
        , n_profile, n_cloud_top, n_layer &
        , i_2stream, l_ir_source_quad, n_source_coeff &
        , n_cloud_type, frac_cloud &
        , ss_prop%phase_fnc(:, :, :, 1:) &
        , ss_prop%omega(:, :, 1:), ss_prop%tau(:, :, 1:) &
        , isolir, sec_00 &
        , trans_cloud, reflect_cloud, trans_0_cloud &
        , source_coeff_cloud &
        , nd_profile, nd_layer, id_ct, nd_max_order &
        , nd_source_coeff, nd_cloud_type &
        )
      IF (ierr /= i_normal) RETURN
!
!
      IF (isolir == IP_infra_red) THEN
!
        CALL ir_source(n_profile, n_cloud_top, n_layer &
          , source_coeff_cloud, diff_planck &
          , l_ir_source_quad, diff_planck_2 &
          , s_down_cloud, s_up_cloud &
          , nd_profile, nd_layer, nd_source_coeff &
          )
!
        DO i=n_cloud_top, n_layer
          DO l=1, n_profile
            s_down_cloud(l, i)=w_cloud(l, i)*s_down_cloud(l, i)
            s_up_cloud(l, i)=w_cloud(l, i)*s_up_cloud(l, i)
          ENDDO
        ENDDO
!
      ENDIF
!
!
!     Calculate the appropriate source terms for the solar: cloudy
!     and clear properties are both needed here.
!
      IF (isolir == IP_solar) THEN
!
        CALL mixed_solar_source(n_profile, n_layer, n_cloud_top &
          , flux_inc_direct &
          , l_scale_solar, adjust_solar_ke &
          , trans_0_free, source_coeff_free &
          , cloud_overlap(1, id_ct-1, i_ovp_dn_ff) &
          , cloud_overlap(1, id_ct-1, i_ovp_dn_cf) &
          , cloud_overlap(1, id_ct-1, i_ovp_dn_fc) &
          , cloud_overlap(1, id_ct-1, i_ovp_dn_cc) &
          , trans_0_cloud, source_coeff_cloud &
          , flux_direct &
          , flux_direct_ground_cloud &
          , s_up_free, s_down_free &
          , s_up_cloud, s_down_cloud &
          , nd_profile, nd_layer, id_ct, nd_source_coeff &
        )
      ENDIF
!
!
!
!     Formulate the matrix equation for the fluxes.
!
      SELECT CASE (i_solver)

      CASE (IP_solver_mix_app_scat)
!
        CALL mix_app_scat(n_profile, n_layer, n_cloud_top &
          , trans_free, reflect_free, s_down_free, s_up_free &
          , trans_cloud, reflect_cloud &
          , s_down_cloud, s_up_cloud &
          , cloud_overlap(1, id_ct-1, i_ovp_dn_ff) &
          , cloud_overlap(1, id_ct-1, i_ovp_dn_cf) &
          , cloud_overlap(1, id_ct-1, i_ovp_dn_fc) &
          , cloud_overlap(1, id_ct-1, i_ovp_dn_cc) &
          , cloud_overlap(1, id_ct-1, i_ovp_up_ff) &
          , cloud_overlap(1, id_ct-1, i_ovp_up_fc) &
          , cloud_overlap(1, id_ct-1, i_ovp_up_cf) &
          , cloud_overlap(1, id_ct-1, i_ovp_up_cc) &
          , flux_inc_down &
          , d_planck_flux_surface, diffuse_albedo &
          , flux_total &
          , nd_profile, nd_layer, id_ct &
          )
!
      CASE (IP_solver_mix_direct, IP_solver_mix_direct_hogan)
!
!       Set the partitioned source functions at the ground.
        IF (isolir == IP_solar) THEN
          DO l=1, n_profile
            source_ground_free(l)=(direct_albedo(l) &
              -diffuse_albedo(l)) &
              *(flux_direct(l, n_layer) &
              -flux_direct_ground_cloud(l))
            source_ground_cloud(l)=(direct_albedo(l) &
              -diffuse_albedo(l)) &
              *flux_direct_ground_cloud(l)
          ENDDO
        ELSE
          DO l=1, n_profile
            source_ground_free(l) &
              =cloud_overlap(l, n_layer, i_ovp_up_ff) &
              *(1.0_RealK-diffuse_albedo(l))*d_planck_flux_surface(l)
            source_ground_cloud(l) &
              =cloud_overlap(l, n_layer, i_ovp_up_cf) &
              *(1.0_RealK-diffuse_albedo(l))*d_planck_flux_surface(l)
          ENDDO
        ENDIF
!
        IF (i_solver == IP_solver_mix_direct) THEN
          CALL solver_mix_direct(n_profile, n_layer, n_cloud_top &
            , trans_free, reflect_free, s_down_free, s_up_free &
            , trans_cloud, reflect_cloud &
            , s_down_cloud, s_up_cloud &
            , cloud_overlap(1, id_ct-1, i_ovp_dn_ff) &
            , cloud_overlap(1, id_ct-1, i_ovp_dn_cf) &
            , cloud_overlap(1, id_ct-1, i_ovp_dn_fc) &
            , cloud_overlap(1, id_ct-1, i_ovp_dn_cc) &
            , cloud_overlap(1, id_ct-1, i_ovp_up_ff) &
            , cloud_overlap(1, id_ct-1, i_ovp_up_fc) &
            , cloud_overlap(1, id_ct-1, i_ovp_up_cf) &
            , cloud_overlap(1, id_ct-1, i_ovp_up_cc) &
            , flux_inc_down &
            , source_ground_free, source_ground_cloud &
            , diffuse_albedo &
            , flux_total &
            , nd_profile, nd_layer, id_ct &
            )

        ELSE IF (i_solver == IP_solver_mix_direct_hogan) THEN
          CALL solver_mix_direct_hogan(n_profile, n_layer, n_cloud_top &
            , trans_free, reflect_free, s_down_free, s_up_free &
            , trans_cloud, reflect_cloud &
            , s_down_cloud, s_up_cloud &
            , cloud_overlap(1, id_ct-1, i_ovp_dn_ff) &
            , cloud_overlap(1, id_ct-1, i_ovp_dn_cf) &
            , cloud_overlap(1, id_ct-1, i_ovp_dn_fc) &
            , cloud_overlap(1, id_ct-1, i_ovp_dn_cc) &
            , cloud_overlap(1, id_ct-1, i_ovp_up_ff) &
            , cloud_overlap(1, id_ct-1, i_ovp_up_fc) &
            , cloud_overlap(1, id_ct-1, i_ovp_up_cf) &
            , cloud_overlap(1, id_ct-1, i_ovp_up_cc) &
            , flux_inc_down &
            , source_ground_free, source_ground_cloud &
            , diffuse_albedo &
            , flux_total &
            , nd_profile, nd_layer, id_ct &
            )

        ENDIF
!
      CASE DEFAULT
!
        WRITE(iu_err, '(/a)') &
          '*** Error: The solver specified is not valid here.'
        ierr=i_err_fatal
        RETURN
!
      END SELECT
!
!
!
      IF (l_clear) THEN
!
        CALL clear_supplement(ierr, n_profile, n_layer, i_solver_clear &
          , trans_free, reflect_free, trans_0_free, source_coeff_free &
          , isolir, flux_inc_direct, flux_inc_down &
          , s_down_clear, s_up_clear &
          , diffuse_albedo, direct_albedo &
          , d_planck_flux_surface &
          , l_scale_solar, adjust_solar_ke &
          , flux_direct_clear, flux_total_clear &
          , nd_profile, nd_layer, nd_source_coeff &
          )
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE MIX_COLUMN
!+ Subroutine to set the solar source terms in a mixed column.
!
! Method:
!        The direct beam is calculated by propagating down through
!        the column. These direct fluxes are used to `define'' the
!        source terms in each layer.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE mixed_solar_source(n_profile, n_layer, n_cloud_top &
        , flux_inc_direct &
        , l_scale_solar, adjust_solar_ke &
        , trans_0_free, source_coeff_free &
        , g_ff, g_fc, g_cf, g_cc &
        , trans_0_cloud, source_coeff_cloud &
        , flux_direct &
        , flux_direct_ground_cloud &
        , s_up_free, s_down_free &
        , s_up_cloud, s_down_cloud &
        , nd_profile, nd_layer, id_ct, nd_source_coeff &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE source_coeff_pointer_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_source_coeff
!           Size allocated for coefficients in the source function
!
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Top cloudy layer
!
!     Special arrays for equivalent extinction:
      LOGICAL, Intent(IN) :: &
          l_scale_solar
!           Scaling applied to solar flux
      REAL  (RealK), Intent(IN) :: &
           adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment to solar fluxes with equivalent extinction
!
      REAL  (RealK), Intent(IN) :: &
          flux_inc_direct(nd_profile)
!           Incident direct solar flux
!
!     Clear-sky optical properties:
      REAL  (RealK), Intent(IN) :: &
          trans_0_free(nd_profile, nd_layer) &
!           Free direct transmission
        , source_coeff_free(nd_profile, nd_layer, nd_source_coeff)
!           Clear-sky source coefficients
!
!     cloudy optical properties:
      REAL  (RealK), Intent(IN) :: &
          trans_0_cloud(nd_profile, nd_layer) &
!           Cloudy transmission
        , source_coeff_cloud(nd_profile, nd_layer, nd_source_coeff)
!           Cloudy reflectance
!
!     Energy transfer coefficients:
      REAL  (RealK), Intent(IN) :: &
          g_ff(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , g_fc(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , g_cf(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , g_cc(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient
!
!     Calculated direct flux and source terms:
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Direct flux
        , flux_direct_ground_cloud(nd_profile) &
!           Direct cloudy flux at ground
        , s_up_free(nd_profile, nd_layer) &
!           Free upward source function
        , s_down_free(nd_profile, nd_layer) &
!           Free downward source function
        , s_up_cloud(nd_profile, nd_layer) &
!           Cloudy upward source function
        , s_down_cloud(nd_profile, nd_layer)
!           Cloudy downward source function
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
      REAL  (RealK) :: &
          solar_top_free(nd_profile) &
!           Free solar flux at top of layer
        , solar_top_cloud(nd_profile) &
!           Cloudy solar flux at top of layer
        , solar_base_free(nd_profile) &
!           Free solar flux at base of layer
        , solar_base_cloud(nd_profile)
!           Cloudy solar flux at base of layer
!
!
!
!     The clear and cloudy direct fluxes are calculated separately
!     and added together to form the total direct flux.
!
!     Set incident fluxes.
      DO l=1, n_profile
        flux_direct(l, 0)=flux_inc_direct(l)
      ENDDO
!
!     With equivalent extinction the direct solar flux must be
!     corrected.
!
      IF (l_scale_solar) THEN
!
        DO i=1, n_cloud_top-1
          DO l=1, n_profile
            flux_direct(l, i) &
              =flux_direct(l, i-1)*trans_0_free(l, i) &
              *adjust_solar_ke(l, i)
            s_up_free(l, i)=source_coeff_free(l, i, IP_scf_solar_up) &
              *flux_direct(l, i-1)
            s_down_free(l, i) &
              =(source_coeff_free(l, i, IP_scf_solar_down) &
              -trans_0_free(l, i))*flux_direct(l, i-1) &
              +flux_direct(l, i)
          ENDDO
        ENDDO
!
      ELSE
!
        DO i=1, n_cloud_top-1
          DO l=1, n_profile
            flux_direct(l, i) &
              =flux_direct(l, i-1)*trans_0_free(l, i)
            s_up_free(l, i)=source_coeff_free(l, i, IP_scf_solar_up) &
              *flux_direct(l, i-1)
            s_down_free(l, i) &
              =source_coeff_free(l, i, IP_scf_solar_down) &
              *flux_direct(l, i-1)
          ENDDO
        ENDDO
!
      ENDIF
!
!
!
!     Clear and cloudy region.
!     Initialize partial fluxes:
      DO l=1, n_profile
        solar_base_free(l)=flux_direct(l, n_cloud_top-1)
        solar_base_cloud(l)=0.0e+00_RealK
      ENDDO
!
!
      DO i=n_cloud_top, n_layer
!
!       Transfer fluxes across the interface. The use of only one
!       cloudy flux implicitly forces random overlap of different
!       subclouds within the cloudy parts of the layer.
!
        DO l=1, n_profile
          solar_top_cloud(l)=g_cc(l, i-1)*solar_base_cloud(l) &
            +g_fc(l, i-1)*solar_base_free(l)
          solar_top_free(l)=g_ff(l, i-1)*solar_base_free(l) &
            +g_cf(l, i-1)*solar_base_cloud(l)
        ENDDO
!
!
!       Propagate the clear and cloudy fluxes through the layer:
!
        IF (l_scale_solar) THEN
!
          DO l=1, n_profile
            solar_base_free(l)=solar_top_free(l) &
              *trans_0_free(l, i)*adjust_solar_ke(l, i)
            solar_base_cloud(l)=solar_top_cloud(l) &
              *trans_0_cloud(l, i)*adjust_solar_ke(l, i)
            s_up_free(l, i)=source_coeff_free(l, i, IP_scf_solar_up) &
              *solar_top_free(l)
            s_down_free(l, i) &
              =(source_coeff_free(l, i, IP_scf_solar_down) &
              -trans_0_free(l, i))*solar_top_free(l) &
              +solar_base_free(l)
            s_up_cloud(l, i) &
              =source_coeff_cloud(l, i, IP_scf_solar_up) &
              *solar_top_cloud(l)
            s_down_cloud(l, i) &
              =(source_coeff_cloud(l, i, IP_scf_solar_down) &
              -trans_0_cloud(l, i))*solar_top_cloud(l) &
              +solar_base_cloud(l)
          ENDDO
!
        ELSE
!
          DO l=1, n_profile
            solar_base_free(l)=solar_top_free(l) &
              *trans_0_free(l, i)
            solar_base_cloud(l)=solar_top_cloud(l) &
              *trans_0_cloud(l, i)
            s_up_free(l, i)=source_coeff_free(l, i, IP_scf_solar_up) &
              *solar_top_free(l)
            s_down_free(l, i) &
              =source_coeff_free(l, i, IP_scf_solar_down) &
              *solar_top_free(l)
            s_up_cloud(l, i) &
              =source_coeff_cloud(l, i, IP_scf_solar_up) &
              *solar_top_cloud(l)
            s_down_cloud(l, i) &
              =source_coeff_cloud(l, i, IP_scf_solar_down) &
              *solar_top_cloud(l)
          ENDDO
!
        ENDIF
!
!
!       Calculate the total direct flux.
!
        DO l=1, n_profile
          flux_direct(l, i)=solar_base_free(l)+solar_base_cloud(l)
        ENDDO
!
      ENDDO
!
!     Pass the last value at the base of the cloud out.
      DO l=1, n_profile
        flux_direct_ground_cloud(l)=solar_base_cloud(l)
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE MIXED_SOLAR_SOURCE
!+ Subroutine to calculate fluxes including only gaseous absorption.
!
! Method:
!        Transmission coefficients for each layer are calculated
!        from the gaseous absorption alone. fluxes are propagated
!        upward or downward through the column using these
!        coefficients and source terms.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE monochromatic_gas_flux(n_profile, n_layer &
        , tau_gas &
        , isolir, sec_0, flux_inc_direct, flux_inc_down &
        , diff_planck, d_planck_flux_surface &
        , diffuse_albedo, direct_albedo &
        , diffusivity_factor &
        , flux_direct, flux_diffuse &
        , nd_profile, nd_layer &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer
!           Maximum number of layers
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , isolir
!           Spectral region
      REAL  (RealK), Intent(IN) :: &
          tau_gas(nd_profile, nd_layer) &
!           Gaseous optical depths
        , sec_0(nd_profile) &
!           Secant of zenith angle
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , flux_inc_down(nd_profile) &
!           Incident diffuse flux
        , d_planck_flux_surface(nd_profile) &
!           Difference in Planckian fluxes between the surface
!           and the overlying air
        , diff_planck(nd_profile, nd_layer) &
!           Difference in Planckian function
        , diffuse_albedo(nd_profile) &
!           Diffuse surface albedo
        , direct_albedo(nd_profile) &
!           Direct surface albedo
        , diffusivity_factor
!           Diffusivity factor
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Direct flux
        , flux_diffuse(nd_profile, 2*nd_layer+2)
!           Diffuse flux
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          trans(nd_profile, nd_layer) &
!           Transmissivities
        , source_up(nd_profile, nd_layer) &
!           Upward source function
        , source_down(nd_profile, nd_layer)
!           Downward source function
!
!     Variables related to the treatment of ill-conditioning
      REAL  (RealK) :: &
          eps_r &
!           The smallest real number such that 1.0-EPS_R is not 1
!           to the computer''s precision
        , sq_eps_r
!           The square root of the above
!
!
!
!     Set the tolerances used in avoiding ill-conditioning, testing
!     on any variable.
      eps_r=epsilon(tau_gas(1, 1))
      sq_eps_r=sqrt(eps_r)
!
!CDIR COLLAPSE
      DO i=1, nd_layer
        DO l=1, nd_profile
            trans(l, i)=exp(-diffusivity_factor*tau_gas(l, i))
        ENDDO
      ENDDO
!
      IF (isolir == IP_solar) THEN
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            source_up(l, i)=0.0e+00_RealK
            source_down(l, i)=0.0e+00_RealK
          ENDDO
        ENDDO
      ELSE IF (isolir == IP_infra_red) THEN
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            source_up(l, i)=(1.0e+00_RealK-trans(l, i)+sq_eps_r) &
              *diff_planck(l, i) &
              /(diffusivity_factor*tau_gas(l, i)+sq_eps_r)
            source_down(l, i)=-source_up(l, i)
          ENDDO
        ENDDO
      ENDIF
!
!     The direct flux.
      IF (isolir == IP_solar) THEN
        DO l=1, nd_profile
          flux_direct(l, 0)=flux_inc_direct(l)
        ENDDO
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
               flux_direct(l, i) &
                  =flux_direct(l, i-1)*exp(-tau_gas(l, i)*sec_0(l))
          ENDDO
        ENDDO
      ENDIF
!
!     Downward fluxes.
      DO l=1, nd_profile
        flux_diffuse(l, 2)=flux_inc_down(l)
      ENDDO
!CDIR COLLAPSE
      DO i=1, nd_layer
        DO l=1, nd_profile
          flux_diffuse(l, 2*i+2)=trans(l, i)*flux_diffuse(l, 2*i) &
            +source_down(l, i)
        ENDDO
      ENDDO
!
!     Upward fluxes.
      IF (isolir == IP_solar) THEN
        DO l=1, nd_profile
          flux_diffuse(l, 2*n_layer+1)= &
            +diffuse_albedo(l)*flux_diffuse(l, 2*n_layer+2) &
            +direct_albedo(l)*flux_direct(l, n_layer)
        ENDDO
      ELSE
        DO l=1, nd_profile
          flux_diffuse(l, 2*n_layer+1)=d_planck_flux_surface(l) &
            +diffuse_albedo(l)*flux_diffuse(l, 2*n_layer+2)
        ENDDO
      ENDIF
!CDIR COLLAPSE
      DO i=nd_layer, 1, -1
        DO l=1, nd_profile
          flux_diffuse(l, 2*i-1)=trans(l, i)*flux_diffuse(l, 2*i+1) &
            +source_up(l, i)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE MONOCHROMATIC_GAS_FLUX
!+ Subroutine to calculate the infra-red radiance ignoring scattering.
!
! Method:
!        Using the secant of the ray transmission coefficients for
!        each layer may be defined and source terms may be calculated.
!        The upward and downward radiances are integrated along
!        their paths.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE monochromatic_ir_radiance(n_profile, n_layer &
         , tau &
         , rad_inc_down &
         , diff_planck, source_ground, albedo_surface_diff &
         , secant_ray &
         , radiance &
         , nd_profile, nd_layer &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer
!           Maximum number of layers
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, nd_layer) &
!           Optical depths of layers
        , rad_inc_down(nd_profile) &
!           Incident downward radiance
        , source_ground(nd_profile) &
!           Source function of ground
        , albedo_surface_diff(nd_profile) &
!           Diffuse albedo
        , diff_planck(nd_profile, nd_layer) &
!           Difference in Planckian function
        , secant_ray
!           Secant of angle with vertical
      REAL  (RealK), Intent(OUT) :: &
          radiance(nd_profile, 2*nd_layer+2)
!           Diffuse radiance
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          trans(nd_profile, nd_layer) &
!           Transmissivities
        , source_up(nd_profile, nd_layer) &
!           Upward source function
        , source_down(nd_profile, nd_layer)
!           Downward source function
!
!     Variables related to the treatment of ill-conditioning
      REAL  (RealK) :: &
          eps_r &
!           The smallest real number such that 1.0-EPS_R is not 1
!           to the computer''s precision
        , sq_eps_r
!           The square root of the above
!
!
!
!     Set the tolerances used in avoiding ill-conditioning, testing
!     on any variable.
      eps_r=epsilon(tau(1, 1))
      sq_eps_r=sqrt(eps_r)
!
      DO i=1, n_layer
        DO l=1, n_profile
          trans(l, i)=exp(-secant_ray*tau(l, i))
        ENDDO
      ENDDO
!
      DO i=1, n_layer
        DO l=1, n_profile
          source_up(l, i)=(1.0e+00_RealK-trans(l, i)+sq_eps_r) &
            *diff_planck(l, i) &
            /(secant_ray*tau(l, i)+sq_eps_r)
          source_down(l, i)=-source_up(l, i)
        ENDDO
      ENDDO
!
!     Downward radiance.
      DO l=1, n_profile
        radiance(l, 2)=rad_inc_down(l)
      ENDDO
      DO i=1, n_layer
        DO l=1, n_profile
          radiance(l, 2*i+2)=trans(l, i)*radiance(l, 2*i) &
            +source_down(l, i)
        ENDDO
      ENDDO
!
!     Upward radiance.
      DO l=1, n_profile
        radiance(l, 2*n_layer+1)=source_ground(l) &
          +albedo_surface_diff(l)*radiance(l, 2*n_layer+2)
      ENDDO
      DO i=n_layer, 1, -1
        DO l=1, n_profile
          radiance(l, 2*i-1)=trans(l, i)*radiance(l, 2*i+1) &
            +source_up(l, i)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE MONOCHROMATIC_IR_RADIANCE
!+ Subroutine to solve for the monochromatic radiances.
!
! Method:
!        The final single scattering properties are calculated
!        and rescaled. An appropriate subroutine is called to
!        calculate the radiances depending on the treatment of
!        cloudiness.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE monochromatic_radiance(ierr &
!                        Atmospheric Propertries
        , n_profile, n_layer, d_mass &
!                        Angular Integration
        , i_angular_integration, i_2stream &
        , l_rescale, n_order_gauss &
        , n_order_phase, ms_min, ms_max, i_truncation, ls_local_trunc &
        , accuracy_adaptive, euler_factor, i_sph_algorithm &
        , i_sph_mode &
!                       Precalculated angular arrays
        , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of Scattering
        , i_scatter_method &
!                        Options for Solver
        , i_solver &
!                        Gaseous Properties
        , k_gas_abs &
!                        Options for Equivalent Extinction
        , l_scale_solar, adjust_solar_ke &
!                        Spectral Region
        , isolir &
!                        Infra-red Properties
        , diff_planck, l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
        , zen_0, zen_00, flux_inc_direct, flux_inc_down & !hmjb
        , i_direct &
!                        Surface Properties
        , d_planck_flux_surface &
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
!                       Optical Properties
        , ss_prop &
!                        Cloudy Properties
        , l_cloud, i_cloud &
!                        Cloud Geometry
        , n_cloud_top &
        , n_cloud_type, frac_cloud &
        , n_region, k_clr, i_region_cloud, frac_region &
        , w_free, w_cloud, cloud_overlap &
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing geometry
        , n_direction, direction &
!                        Calculated Fluxes
        , flux_direct, flux_total &
!                       Calculated Radiances
        , radiance &
!                       Calculated mean radiances
        , j_radiance &
!                        Flags for Clear-sky Calculation
        , l_clear, i_solver_clear &
!                        Clear-sky Fluxes Calculated
        , flux_direct_clear, flux_total_clear &
!                        Dimensions of Arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_cloud_type, nd_region, nd_overlap_coeff &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
        , nd_direction, nd_source_coeff &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE angular_integration_pcf
      USE surface_spec_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , nd_layer_clr &
!           Maximum number of completely clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_flux_profile &
!           Maximum number of profiles in arrays of fluxes
        , nd_radiance_profile &
!           Maximum number of profiles in arrays of radiances
        , nd_j_profile &
!           Maximum number of profiles in arrays of mean radiances
        , nd_column &
!           Number of columns per point
        , nd_cloud_type &
!           Maximum number of types of cloud
        , nd_region &
!           Maximum number of cloudy regions
        , nd_overlap_coeff &
!           Maximum number of overlap coefficients
        , nd_max_order &
!           Maximum order of spherical harmonics used
        , nd_sph_coeff &
!           Allocated size for spherical coefficients
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for orders of BRDFs
        , nd_viewing_level &
!           Allocated size for levels where radiances are calculated
        , nd_direction &
!           Allocated size for viewing directions
        , nd_source_coeff
!           Size allocated for source coefficients
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!                        Atmospheric properties
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
      REAL  (RealK), Intent(IN) :: &
          d_mass(nd_profile, nd_layer)
!           Mass thickness of each layer
!
!                        Angular integration
      INTEGER, Intent(IN) :: &
          i_angular_integration &
!           Angular integration scheme
        , i_2stream &
!           Two-stream scheme
        , n_order_gauss &
!           Order of Gaussian integration
        , n_order_phase &
!           Highest order retained in the phase function
        , i_truncation &
!           Type of spherical truncation adopted
        , ms_min &
!           Lowest azimuthal order calculated
        , ms_max &
!           Highest azimuthal order calculated
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient for (m, m) for each m
        , ls_local_trunc(0: nd_max_order) &
!           Orders of truncation at each azimuthal order
        , i_sph_mode &
!           Mode in which teh spherical harmonic solver is being used
        , i_sph_algorithm
!           Algorithm used for spherical harmonic calculation
      LOGICAL, Intent(IN) :: &
          l_rescale
!           Rescale optical properties
      REAL  (RealK) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-Gordan coefficients
        , uplm_zero(nd_sph_coeff) &
!           Values of spherical harmonics at polar angles pi/2
        , uplm_sol(nd_radiance_profile, nd_sph_coeff)
!           Values of spherical harmonics in the solar direction
      REAL  (RealK), Intent(IN) :: &
          accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last term of an alternating series
!
!                        Treatment of scattering
      INTEGER, Intent(IN) :: &
          i_scatter_method
!
!                        Options for solver
      INTEGER, Intent(IN) :: &
          i_solver
!           Solver used
!
!                        Gaseous properties
      REAL  (RealK), Intent(IN) :: &
          k_gas_abs(nd_profile, nd_layer)
!           Gaseous absorptive extinctions
!
!                        Variables for equivalent extinction
      LOGICAL, Intent(IN) :: &
          l_scale_solar
!           Apply scaling to solar flux
      REAL  (RealK), Intent(IN) :: &
          adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment of solar beam with equivalent extinction
!
!                        Spectral region
      INTEGER, Intent(IN) :: &
          isolir
!           Visible or IR
!
!                        Infra-red properties
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic IR-source
      REAL  (RealK), Intent(IN) :: &
          diff_planck(nd_profile, nd_layer) &
!           DIfferences in the Planckian function across layers
        , diff_planck_2(nd_profile, nd_layer)
!           Twice the second differences of Planckian source function
!
!                        Conditions at TOA
      REAL  (RealK), Intent(IN) :: &
          zen_0(nd_profile) &
        , zen_00(nd_profile, nd_layer) & !hmjb
!           Secants (two-stream) or cosines (spherical harmonics)
!           of the solar zenith angles
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , flux_inc_down(nd_profile)
!           Incident downward flux
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_radiance_profile, 0: nd_layer)
!           Direct radiance (the first row contains the incident
!           solar radiance: the other rows are calculated)
!
!                        Surface properties
      REAL  (RealK), Intent(IN) :: &
          d_planck_flux_surface(nd_profile)
!           Differential Planckian flux from the surface
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of trunation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!                        Cloudy properties
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Clouds required
      INTEGER, Intent(IN) :: &
          i_cloud
!           Cloud scheme used
!
!                        Cloud geometry
      INTEGER, Intent(IN) :: &
          n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_type &
!           Number of types of clouds
        , n_region &
!           Number of cloudy regions
        , k_clr &
!           Index of clear-sky region
        , i_region_cloud(nd_cloud_type)
!           Regions in which types of clouds fall
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy fraction
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of different types of cloud
        , w_free(nd_profile, id_ct: nd_layer) &
!           Clear-sky fraction
        , cloud_overlap(nd_profile, id_ct-1: nd_layer &
            , nd_overlap_coeff) &
!           Coefficients for energy transfer at interfaces
        , area_column(nd_profile, nd_column) &
!           Areas of columns
        , frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fractions of total cloud occupied by each region
!
!
!                        Levels where radiance are calculated
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2)
!           Viewing directions
!
!                        Calculated Fluxes
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct flux
        , flux_total(nd_flux_profile, 2*nd_layer+2)
!           Total flux
!
!                        Calculated radiances
      REAL  (RealK), Intent(OUT) :: &
          radiance(nd_radiance_profile, nd_viewing_level, nd_direction)
!           Radiances
!                        Calculated mean radiances
      REAL  (RealK), Intent(OUT) :: &
          j_radiance(nd_j_profile, nd_viewing_level)
!           Mean radiances
!
!                        Flags for clear-sky calculations
      LOGICAL, Intent(IN) :: &
          l_clear
!           Calculate clear-sky properties
      INTEGER, Intent(IN) :: &
          i_solver_clear
!           Clear solver used
!
!                        Clear-sky fluxes calculated
      REAL  (RealK), Intent(OUT) :: &
          flux_direct_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky direct flux
        , flux_total_clear(nd_flux_profile, 2*nd_layer+2)
!           Clear-sky total flux
!
!
!
!     Local variables.
      INTEGER &
          k &
!           Loop variable
        , l &
!           Loop variable
        , i
!           Loop variable
      REAL  (RealK), allocatable :: &
          tau_clr_f(:, :)
!           Clear-sky optical depths for the whole column
!
!     Subroutines called:
!      EXTERNAL &
!          single_scattering_all, rescale_tau_omega &
!        , monochromatic_radiance_tseq &
!        , monochromatic_radiance_sph &
!        , gauss_angle
!
!
!
!     Calculate the optical depths and albedos of single scattering.
!     The phase function is not involved here as that is constant
!     across the band, whereas these parameters vary with the gaseous
!     absorption.
!
      CALL single_scattering_all(i_scatter_method &
!                        Atmospheric properties
        , n_profile, n_layer, d_mass &
!                        Cloudy properties
        , l_cloud, n_cloud_top, n_cloud_type &
!                        Optical properties
        , ss_prop &
        , k_gas_abs &
!                        Single scattering properties
!                        Dimensions of arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct &
        )
!
!
!
      IF ( (i_angular_integration == IP_two_stream).OR. &
           (i_angular_integration == IP_spherical_harmonic) ) THEN
!
!       Rescale the optical depth and albedo of single scattering.
!
        IF (l_rescale) THEN
!
!
          IF (l_cloud) THEN
!
!CDIR COLLAPSE
            DO k=0, n_cloud_type
              CALL rescale_tau_omega(n_profile, 1 &
                , n_layer &
                , ss_prop%tau(:, :, k), ss_prop%omega(:, :, k) &
                , ss_prop%forward_scatter(:, :, k) &
                , nd_profile, nd_layer, id_ct &
                )
            ENDDO
          ELSE
!CDIR COLLAPSE
            CALL rescale_tau_omega(n_profile, 1 &
              , n_layer &
              , ss_prop%tau(:, :, 0), ss_prop%omega(:, :, 0) &
              , ss_prop%forward_scatter(:, :, 0) &
              , nd_profile, nd_layer, id_ct &
              )
          ENDIF
!
        ENDIF
!
      ENDIF
!
!
!     Now divide the algorithmic path depending on the option
!     for angular integration.
!
      IF (i_angular_integration == IP_two_stream) THEN
!
!       The standard two-stream approximations.
        CALL monochromatic_radiance_tseq(ierr &
!                       Atmospheric Propertries
          , n_profile, n_layer &
!                       Options for Solver
          , i_2stream, i_solver, i_scatter_method &
!                       Optical Properties
          , l_scale_solar, adjust_solar_ke &
!                       Spectral Region
          , isolir &
!                       Infra-red Properties
          , diff_planck, l_ir_source_quad, diff_planck_2 &
!                       Conditions at TOA
          , zen_0, zen_00, flux_inc_direct, flux_inc_down & !hmjb
!                       Surface Properties
          , d_planck_flux_surface &
          , rho_alb &
!                       Optical Properties
          , ss_prop &
!                       Cloudy Properties
          , i_cloud &
!                       Cloud Geometry
          , n_cloud_top &
          , n_cloud_type, frac_cloud &
          , n_region, k_clr, i_region_cloud, frac_region &
          , w_free, w_cloud, cloud_overlap &
          , n_column_slv, list_column_slv &
          , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Fluxes Calculated
          , flux_direct, flux_total &
!                       Flags for Clear-sky Calculation
          , l_clear, i_solver_clear &
!                       Clear-sky Fluxes Calculated
          , flux_direct_clear, flux_total_clear &
!                       Dimensions of Arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
          , nd_cloud_type, nd_region, nd_overlap_coeff &
          , nd_source_coeff, nd_max_order &
          )
!
      ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
!       The spherical harmonic option:
        CALL monochromatic_radiance_sph(ierr &
!                       Atmospheric Propertries
          , n_profile, n_layer &
!                       Angular Integration
          , n_order_phase, ms_min, ms_max, i_truncation, ls_local_trunc &
          , accuracy_adaptive, euler_factor, i_sph_algorithm &
          , i_sph_mode, l_rescale &
!                       Precalculated angular arrays
          , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                       Options for Equivalent Extinction
          , l_scale_solar, adjust_solar_ke &
!                       Spectral Region
          , isolir &
!                       Infra-red Properties
          , diff_planck, l_ir_source_quad, diff_planck_2 &
!                       Conditions at TOA
          , zen_0, zen_00, flux_inc_down &
          , i_direct &
!                       Surface Properties
          , d_planck_flux_surface &
          , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
          , f_brdf, brdf_sol, brdf_hemi &
!                       Optical properties
          , ss_prop &
!                       Cloudy Properties
          , i_cloud &
!                       Cloud Geometry
          , n_cloud_top &
          , n_column_slv, list_column_slv &
          , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
          , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing geometry
          , n_direction, direction &
!                       Calculated Fluxes
          , flux_direct, flux_total &
!                       Calculated radiances
          , radiance &
!                       Calculated mean radiances
          , j_radiance &
!                       Dimensions of Arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_max_order, nd_sph_coeff &
          , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
          , nd_direction &
          )
!
      ELSE IF (i_angular_integration == IP_ir_gauss) THEN
!
!       Full angular resolution using Gaussian integration.
!
        ALLOCATE(tau_clr_f(nd_profile, nd_layer))
        DO i=1, n_cloud_top-1
          DO l=1, n_profile
            tau_clr_f(l, i)=ss_prop%tau_clr(l, i)
          ENDDO
        ENDDO
        DO i=n_cloud_top, n_layer
          DO l=1, n_profile
            tau_clr_f(l, i)=ss_prop%tau_clr(l, i)
          ENDDO
        ENDDO
!
        CALL gauss_angle(n_profile, n_layer &
          , n_order_gauss &
          , tau_clr_f &
          , flux_inc_down &
          , diff_planck, d_planck_flux_surface &
          , rho_alb(1, IP_surf_alb_diff) &
          , flux_total &
          , l_ir_source_quad, diff_planck_2 &
          , nd_profile, nd_layer &
          )
!
        DEALLOCATE(tau_clr_f)
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE MONOCHROMATIC_RADIANCE
!+ Subroutine to solve for the monochromatic radiances.
!
! Method:
!        The final single scattering properties are calculated
!        and rescaled. An appropriate subroutine is called to
!        calculate the radiances depending on the treatment of
!        cloudiness.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE monochromatic_radiance_sph(ierr &
!                        Atmospheric Propertries
        , n_profile, n_layer &
!                        Angular Integration
        , n_order_phase, ms_min, ms_max, i_truncation, ls_local_trunc &
        , accuracy_adaptive, euler_factor, i_sph_algorithm &
        , i_sph_mode, l_rescale &
!                       Precalculated angular arrays
        , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Options for Equivalent Extinction
        , l_scale_solar, adjust_solar_ke &
!                        Spectral Region
        , isolir &
!                        Infra-red Properties
        , diff_planck, l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
        , zen_0, zen_00, flux_inc_down &
        , i_direct &
!                        Surface Properties
        , d_planck_flux_surface &
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
!                        Optical Properties
        , ss_prop &
!                        Cloudy Properties
        , i_cloud &
!                        Cloud Geometry
        , n_cloud_top &
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing geometry
        , n_direction, direction &
!                        Calculated Fluxes
        , flux_direct, flux_total &
!                       Calculated radiances
        , radiance &
!                       Calculated mean radiances
        , j_radiance &
!                        Dimensions of Arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
        , nd_direction &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE def_std_io_icf
      USE cloud_scheme_pcf
      USE angular_integration_pcf
      USE sph_algorithm_pcf
      USE solver_pcf
      USE surface_spec_pcf
      USE spectral_region_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , nd_layer_clr &
!           Maximum number of completely clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_flux_profile &
!           Maximum number of profiles in arrays of fluxes
        , nd_radiance_profile &
!           Maximum number of profiles in arrays of radiances
        , nd_j_profile &
!           Maximum number of profiles in arrays of mean radiances
        , nd_column &
!           Number of columns per point
        , nd_max_order &
!           Maximum order of spherical harmonics used
        , nd_sph_coeff &
!           Allocated size for spherical coefficients
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for orders of BRDFs
        , nd_viewing_level &
!           Allocated size for levels where radiances are calculated
        , nd_direction
!           Allocated size for viewing directions
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!                        Atmospheric properties
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
!
!                        Angular integration
      INTEGER, Intent(IN) :: &
          n_order_phase &
!           Highest order retained in the phase function
        , i_truncation &
!           Type of spherical truncation adopted
        , ms_min &
!           Lowest azimuthal order calculated
        , ms_max &
!           Highest azimuthal order calculated
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient for (m, m) for each m
        , ls_local_trunc(0: nd_max_order) &
!           Orders of truncation at each azimuthal order
        , i_sph_mode &
!           Mode in which the spherical harmonic solver is being used
        , i_sph_algorithm
!           Algorithm used for spherical harmonic calculation
      LOGICAL, Intent(IN) :: &
          l_rescale
!           Flag for rescaling of the optical properties
      REAL  (RealK) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-Gordan coefficients
        , uplm_zero(nd_sph_coeff) &
!           Values of spherical harmonics at polar angles pi/2
        , uplm_sol(nd_profile, nd_sph_coeff)
!           Values of spherical harmonics in the solar direction
      REAL  (RealK), Intent(IN) :: &
          accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last term of an alternating series
!
!                        Variables for equivalent extinction
      LOGICAL, Intent(IN) :: &
          l_scale_solar
!           Apply scaling to solar flux
      REAL  (RealK), Intent(IN) :: &
          adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment of solar beam with equivalent extinction
!
!                        Spectral region
      INTEGER, Intent(IN) :: &
          isolir
!           Visible or IR
!
!                        Infra-red properties
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic IR-source
      REAL  (RealK), Intent(IN) :: &
          diff_planck(nd_profile, nd_layer) &
!           DIfferences in the Planckian function across layers
        , diff_planck_2(nd_profile, nd_layer)
!           Twice the second differences of Planckian source function
!
!                        Conditions at TOA
      REAL  (RealK), Intent(IN) :: &
          zen_0(nd_profile) &
        , zen_00(nd_profile, nd_layer) &
!           Secants (two-stream) or cosines (spherical harmonics)
!           of the solar zenith angles
        , flux_inc_down(nd_profile)
!           Incident downward flux
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_profile, 0: nd_layer)
!           Direct radiance (the first row contains the incident
!           solar radiance: the other rows are calculated)
!
!                        Surface properties
      REAL  (RealK), Intent(IN) :: &
          d_planck_flux_surface(nd_profile)
!           Differential Planckian flux from the surface
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of trunation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!                      Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!                        Cloudy properties
      INTEGER, Intent(IN) :: &
          i_cloud
!           Cloud scheme used
!
!                        Cloud geometry
      INTEGER, Intent(IN) :: &
          n_cloud_top
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
        area_column(nd_profile, nd_column)
!           Areas of columns
!
!
!                        Levels where radiance are calculated
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2)
!           Viewing directions
!
!                        Calculated Fluxes
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct flux
        , flux_total(nd_flux_profile, 2*nd_layer+2)
!           Total flux
!
!                        Calculated radiances
      REAL  (RealK), Intent(OUT) :: &
          radiance(nd_radiance_profile, nd_viewing_level, nd_direction)
!           Radiances
!
!                        Calculated mean radiances
      REAL  (RealK), Intent(OUT) :: &
          j_radiance(nd_j_profile, nd_viewing_level)
!           Mean radiances
!
!
!     Local variables.
      INTEGER &
          nd_red_eigensystem &
!           Size allowed for the reduced eigensystem
        , nd_sph_equation &
!           Size allowed for spherical harmonic equations
        , nd_sph_diagonal &
!           Size allowed for diagonals of the spherical harmonic
!           matrix
        , nd_sph_cf_weight &
!           Size allowed for entities to be incremented by the
!           complementary function of the linear system
        , nd_sph_u_range &
!           Size allowed for range of values of u^+|- contributing
!           on any viewing level
        , nd_profile_column
!           Size allowed for profiles taken simultaneously in a
!           decomposition into columns
      INTEGER &
          l
!           Loop variable
      REAL  (RealK), allocatable :: &
          tau_clr_f(:, :) &
!           Clear-sky optical depth for the whole column
        , omega_clr_f(:, :) &
!           Clear-sky albedo of single scattering for the whole column
        , phase_fnc_clr_f(:, :, :) &
!           Clear-sky phase function for the whole column
        , forward_scatter_clr_f(:, :) &
!           Clear-sky forward scattering for the whole column
        , phase_fnc_solar_clr_f(:, :, :)
!           Clear-sky solar phase function in viewing directions
!           for the whole column
!
!     Subroutines called:
!      EXTERNAL &
!          copy_clr_full, copy_clr_sol &
!        , sph_solver, calc_radiance_ipa
!0   &  , SPH_SOLVER_CPL
!
!
!
!     Split the method os folution according to the cloud scheme.
      IF (i_cloud == IP_cloud_clear) THEN
!
!       Precalculate dimensions for the dynamically allocated
!       arrays.
        nd_red_eigensystem=(nd_max_order+1)/2
        nd_sph_equation=2*nd_layer*nd_red_eigensystem
        nd_sph_diagonal=6*nd_red_eigensystem
        IF (i_sph_algorithm == IP_sph_direct) THEN
          nd_sph_cf_weight=nd_max_order+1
          nd_sph_u_range=2*nd_red_eigensystem
        ELSE IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
          nd_sph_cf_weight=nd_direction
          nd_sph_u_range=nd_sph_equation
        ENDIF
!
!       Allocate and set dynamic arrays.
        ALLOCATE(tau_clr_f(nd_profile, nd_layer))
        ALLOCATE(omega_clr_f(nd_profile, nd_layer))
        ALLOCATE(phase_fnc_clr_f(nd_profile, nd_layer, nd_max_order))
        ALLOCATE(forward_scatter_clr_f(nd_profile, nd_layer))
        ALLOCATE(phase_fnc_solar_clr_f(nd_radiance_profile &
          , nd_layer, nd_direction))
!
        CALL copy_clr_full(n_profile, n_layer, n_cloud_top &
          , n_order_phase &
          , ss_prop%tau_clr, ss_prop%omega_clr, ss_prop%phase_fnc_clr &
          , ss_prop%tau, ss_prop%omega, ss_prop%phase_fnc &
          , tau_clr_f, omega_clr_f, phase_fnc_clr_f &
!                       Sizes of arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_max_order &
          )
        IF ( (i_sph_algorithm == IP_sph_reduced_iter).AND. &
             (isolir == IP_solar) ) THEN
          CALL copy_clr_sol(n_profile, n_layer, n_cloud_top &
            , n_direction, l_rescale &
            , ss_prop%forward_scatter_clr &
            , ss_prop%phase_fnc_solar_clr &
            , ss_prop%forward_scatter, ss_prop%phase_fnc_solar &
            , forward_scatter_clr_f &
            , phase_fnc_solar_clr_f &
!                       Sizes of arrays
            , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_direction &
            )
        ENDIF
!
        CALL sph_solver(ierr &
!                       Atmospheric sizes
          , n_profile, n_layer &
!                       Angular integration
          , ms_min, ms_max, i_truncation, ls_local_trunc &
          , cg_coeff, uplm_zero, ia_sph_mm &
          , accuracy_adaptive, euler_factor &
          , i_sph_algorithm, i_sph_mode &
!                       Spectral Region
          , isolir &
!                        Options for Equivalent Extinction
          , l_scale_solar, adjust_solar_ke &
!                       Solar Fields
          , i_direct, zen_0, uplm_sol &
!                       Infra-red Properties
          , diff_planck, flux_inc_down &
          , l_ir_source_quad, diff_planck_2 &
!                       Optical properies
          , tau_clr_f, omega_clr_f, phase_fnc_clr_f &
          , phase_fnc_solar_clr_f &
!                       Surface Conditions
          , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
          , f_brdf, brdf_sol, brdf_hemi &
          , d_planck_flux_surface &
!                       Levels for calculating radiances
          , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
          , n_direction, direction &
!                       Radiances Calculated
          , flux_direct, flux_total, radiance, j_radiance &
!                       Dimensions of arrays
          , nd_profile, nd_layer &
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_max_order, nd_sph_coeff &
          , nd_brdf_basis_fnc, nd_brdf_trunc &
          , nd_red_eigensystem, nd_sph_equation, nd_sph_diagonal &
          , nd_sph_cf_weight, nd_sph_u_range &
          , nd_viewing_level, nd_direction &
          )
!
        IF (ierr /= i_normal) RETURN
!
      ELSEIF ( (i_cloud == IP_cloud_mix_max).OR. &
               (i_cloud == IP_cloud_mix_random).OR. &
               (i_cloud == IP_cloud_triple).OR. &
               (i_cloud == IP_cloud_part_corr).OR. &
               (i_cloud == IP_cloud_part_corr_cnv) ) THEN
!
        WRITE(iu_err, '(/a)') &
          '*** Error: Radiances cannot yet be computed using ' &
          //'coupled overlaps.'
        ierr=i_err_fatal
        RETURN
!0!
!0!       Clouds are treated using coupled overlaps.
!0!
!0!       Precalculate dimensions for the dynamically allocated
!0!       arrays.
!0        ND_RED_EIGENSYSTEM=(ND_MAX_ORDER+1)/2
!0        ND_SPH_EQUATION=2*ND_RED_EIGENSYSTEM*((N_CLOUD_TOP-1)
!0     &    +(ND_LAYER-N_CLOUD_TOP+1)*ND_REGION)
!0        ND_SPH_DIAGONAL=6*ND_RED_EIGENSYSTEM*ND_REGION
!0        IF (I_SPH_ALGORITHM.EQ.IP_SPH_DIRECT) THEN
!0          ND_SPH_CF_WEIGHT=ND_MAX_ORDER+1
!0          ND_SPH_U_RANGE=2*ND_RED_EIGENSYSTEM
!0        ELSE IF (I_SPH_ALGORITHM.EQ.IP_SPH_REDUCED_ITER) THEN
!0          ND_SPH_CF_WEIGHT=ND_DIRECTION
!0          ND_SPH_U_RANGE=ND_SPH_EQUATION
!0        ENDIF
!0!
!0        CALL SPH_SOLVER_CPL(IERR
!0!                       Atmospheric sizes
!0     &    , N_PROFILE, N_LAYER, N_CLOUD_TOP, N_REGION, K_CLR
!0!                       Angular integration
!0     &    , MS_MIN, MS_MAX, I_TRUNCATION, LS_LOCAL_TRUNC
!0     &    , CG_COEFF, UPLM_ZERO, IA_SPH_MM
!0     &    , ACCURACY_ADAPTIVE, EULER_FACTOR
!0     &    , I_SPH_ALGORITHM, I_SPH_MODE, L_RESCALE
!0!                       Spectral Region
!0     &    , ISOLIR
!0!                       Options for Equivalent Extinction
!0     &    , L_SCALE_SOLAR, ADJUST_SOLAR_KE
!0!                       Solar Fields
!0     &    , I_DIRECT, ZEN_0, UPLM_SOL
!0!                       Infra-red Properties
!0     &    , DIFF_PLANCK, FLUX_INC_DOWN
!0     &    , L_IR_SOURCE_QUAD, DIFF_PLANCK_2
!0*N+
!0!                       Optical properies
!0     &    , TAU_CLR, OMEGA_CLR, PHASE_FNC_CLR, PHASE_FNC_SOLAR_CLR
!0     &    , FORWARD_SCATTER_CLR
!0     &    , TAU, OMEGA, PHASE_FNC, PHASE_FNC_SOLAR
!0     &    , FORWARD_SCATTER
!0*N-
!0**O+
!0*!                       Optical properies
!0*     &    , TAU_FREE, OMEGA_FREE, PHASE_FNC_FREE
!0*     &    , PHASE_FNC_SOLAR_FREE, FORWARD_SCATTER_FREE
!0**O-
!0!                       Cloud geometry
!0     &    , W_FREE, W_CLOUD, FRAC_REGION, CLOUD_OVERLAP
!0!                       Surface Conditions
!0     &    , LS_BRDF_TRUNC, N_BRDF_BASIS_FNC, RHO_ALB
!0     &    , F_BRDF, BRDF_SOL, BRDF_HEMI
!0     &    , D_PLANCK_FLUX_SURFACE
!0!                       Levels for calculating radiances
!0     &    , N_VIEWING_LEVEL, I_RAD_LAYER, FRAC_RAD_LAYER
!0!                       Viewing Geometry
!0     &    , N_DIRECTION, DIRECTION
!0!                       Calculated Radiances or Fluxes
!0     &    , FLUX_DIRECT, FLUX_TOTAL, RADIANCE, J_RADIANCE
!0!                       Dimensions of arrays
!0*N+
!0     &    , ND_PROFILE, ND_LAYER, ND_LAYER_CLR, ID_CT
!0     &    , ND_REGION, ND_OVERLAP_COEFF
!0*N-
!0**O+
!0*     &    , ND_PROFILE, ND_LAYER, ID_CT, ND_REGION, ND_OVERLAP_COEFF
!0**O-
!0     &    , ND_FLUX_PROFILE, ND_RADIANCE_PROFILE, ND_J_PROFILE
!0     &    , ND_MAX_ORDER, ND_SPH_COEFF
!0     &    , ND_BRDF_BASIS_FNC, ND_BRDF_TRUNC
!0     &    , ND_RED_EIGENSYSTEM, ND_SPH_EQUATION, ND_SPH_DIAGONAL
!0     &    , ND_SPH_CF_WEIGHT, ND_SPH_U_RANGE
!0     &    , ND_VIEWING_LEVEL, ND_DIRECTION
!0     &    )
!0        IF (IERR.NE.I_NORMAL) RETURN
!
      ELSEIF (i_cloud == IP_cloud_column_max) THEN
!
!       Clouds are treated using the independent pixel approximation,
!       as directed by the decompositional arrays.
!
!       Set a dimension to allow the subcolumns of several profiles
!       to be considered at once.
        nd_profile_column=max(1, n_profile)
        DO l=1, n_profile
          nd_profile_column=max(nd_profile_column, n_column_slv(l))
        ENDDO
!
!       Precalculate dimensions for the dynamically allocated
!       arrays.
        nd_red_eigensystem=(nd_max_order+1)/2
        nd_sph_equation=2*nd_layer*nd_red_eigensystem
        nd_sph_diagonal=6*nd_red_eigensystem
        IF (i_sph_algorithm == IP_sph_direct) THEN
          nd_sph_cf_weight=nd_max_order+1
          nd_sph_u_range=2*nd_red_eigensystem
        ELSE IF (i_sph_algorithm == IP_sph_reduced_iter) THEN
          nd_sph_cf_weight=nd_direction
          nd_sph_u_range=nd_sph_equation
        ENDIF
!
!
        CALL calc_radiance_ipa(ierr &
!                        Atmospheric Properties
          , n_profile, n_layer, n_cloud_top &
!                       Angular Integration
          , n_order_phase, ms_min, ms_max, ls_local_trunc &
          , i_truncation, accuracy_adaptive, euler_factor &
          , i_sph_algorithm, i_sph_mode, l_rescale &
!                       Precalculated angular arrays
          , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Options for Equivalent Extinction
          , l_scale_solar, adjust_solar_ke &
!                        Spectral Region
          , isolir &
!                        Infra-red Properties
          , diff_planck &
          , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
          , flux_inc_down, zen_0 &
!                        Conditions at Surface
          , d_planck_flux_surface &
          , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
          , f_brdf, brdf_sol, brdf_hemi &
!                       Optical Properties
          , ss_prop &
!                        Cloud Geometry
          , n_column_slv, list_column_slv &
          , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
          , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
          , n_direction, direction &
!                       Calculated fluxes or radiances
          , flux_direct, flux_total, i_direct, radiance, j_radiance &
!                        Dimensions of Arrays
          , nd_profile, nd_layer  &
          , nd_column &
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_max_order, nd_sph_coeff &
          , nd_brdf_basis_fnc, nd_brdf_trunc &
          , nd_red_eigensystem, nd_sph_equation, nd_sph_diagonal &
          , nd_sph_cf_weight, nd_sph_u_range &
          , nd_viewing_level, nd_direction &
          , nd_profile_column &
          )
!
        IF (ierr /= i_normal) RETURN
!
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE MONOCHROMATIC_RADIANCE_SPH
!+ Subroutine to solve for the monochromatic radiances.
!
! Method:
!        The final single scattering properties are calculated
!        and rescaled. An appropriate subroutine is called to
!        calculate the radiances depending on the treatment of
!        cloudiness.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE monochromatic_radiance_tseq(ierr &
!                        Atmospheric Propertries
        , n_profile, n_layer &
!                        Options for Solver
        , i_2stream, i_solver, i_scatter_method &
!                        Optical Properties
        , l_scale_solar, adjust_solar_ke &
!                        Spectral Region
        , isolir &
!                        Infra-red Properties
        , diff_planck, l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
        , sec_0, sec_00, flux_inc_direct, flux_inc_down & !hmjb
!                        Surface Properties
        , d_planck_flux_surface &
        , rho_alb &
!                        Optical Properties
        , ss_prop &
!                        Cloudy Properties
        , i_cloud &
!                        Cloud Geometry
        , n_cloud_top &
        , n_cloud_type, frac_cloud &
        , n_region, k_clr, i_region_cloud, frac_region &
        , w_free, w_cloud, cloud_overlap &
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                        Fluxes Calculated
        , flux_direct, flux_total &
!                        Flags for Clear-sky Calculation
        , l_clear, i_solver_clear &
!                        Clear-sky Fluxes Calculated
        , flux_direct_clear, flux_total_clear &
!                        Dimensions of Arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_cloud_type, nd_region, nd_overlap_coeff &
        , nd_source_coeff, nd_max_order &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE def_std_io_icf
      USE cloud_scheme_pcf
      USE spectral_region_pcf
      USE solver_pcf
      USE surface_spec_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , nd_layer_clr &
!           Size allocated for completely clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_column &
!           Number of columns per point
        , nd_cloud_type &
!           Maximum number of types of cloud
        , nd_region &
!           Maximum number of cloudy regions
        , nd_overlap_coeff &
!           Maximum number of overlap coefficients
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_max_order
!           Size allocated for spherical harmonics
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!                        Atmospheric properties
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
!
!                        Angular integration
      INTEGER, Intent(IN) :: &
          i_2stream &
!           Two-stream scheme
        , i_scatter_method
!           Method of treating scattering
!
!                        Options for solver
      INTEGER, Intent(IN) :: &
          i_solver
!           Solver used
!
!                        Variables for equivalent extinction
      LOGICAL, Intent(IN) :: &
          l_scale_solar
!           Apply scaling to solar flux
      REAL  (RealK), Intent(IN) :: &
          adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment of solar beam with equivalent extinction
!
!                        Spectral region
      INTEGER, Intent(IN) :: &
          isolir
!           Visible or IR
!
!                        Infra-red properties
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic IR-source
      REAL  (RealK), Intent(IN) :: &
          diff_planck(nd_profile, nd_layer) &
!           DIfferences in the Planckian function across layers
        , diff_planck_2(nd_profile, nd_layer)
!           Twice the second differences of Planckian source function
!
!                        Conditions at TOA
      REAL  (RealK), Intent(IN) :: &
          sec_0(nd_profile) &
        , sec_00(nd_profile, nd_layer) & !hmjb
!           Secants (two-stream) or cosines (spherical harmonics)
!           of the solar zenith angles
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , flux_inc_down(nd_profile)
!           Incident downward flux
!
!                        Surface properties
      REAL  (RealK), Intent(IN) :: &
          d_planck_flux_surface(nd_profile)
!           Differential Planckian flux from the surface
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, 2)
!           Weights of the basis functions
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!                        Cloudy properties
      INTEGER, Intent(IN) :: &
          i_cloud
!           Cloud scheme used
!
!                        Cloud geometry
      INTEGER, Intent(IN) :: &
          n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_type &
!           Number of types of clouds
        , n_region &
!           Number of cloudy regions
        , i_region_cloud(nd_cloud_type) &
!           Regions in which types of clouds fall
        , k_clr
!           Index of clear-sky region
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy fraction
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of different types of cloud
        , w_free(nd_profile, id_ct: nd_layer) &
!           Clear-sky fraction
        , cloud_overlap(nd_profile, id_ct-1: nd_layer &
            , nd_overlap_coeff) &
!           Coefficients for energy transfer at interfaces
        , area_column(nd_profile, nd_column) &
!           Areas of columns
        , frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fractions of total cloud occupied by each region
!
!**o+
!*!                        cloudy optical properties
!*      real  (realk), intent(in) ::
!*     &    tau_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!*!           cloudy optical depth
!*     &  , omega_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!*!           cloudy albedo of single scattering
!*     &  , phase_fnc_cloud(nd_profile, id_ct: nd_layer
!*     &      , 1, nd_cloud_type)
!*!           cloudy phase functions
!**o-
!
!                        Calculated Fluxes
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Direct flux
        , flux_total(nd_profile, 2*nd_layer+2)
!           Total flux
!
!                        Flags for clear-sky calculations
      LOGICAL, Intent(IN) :: &
          l_clear
!           Calculate clear-sky properties
      INTEGER, Intent(IN) :: &
          i_solver_clear
!           Clear solver used
!
!                        Clear-sky fluxes calculated
      REAL  (RealK), Intent(OUT) :: &
          flux_direct_clear(nd_profile, 0: nd_layer) &
!           Clear-sky direct flux
        , flux_total_clear(nd_profile, 2*nd_layer+2)
!           Clear-sky total flux
!
!
!
!     Local variables.
      INTEGER &
          nd_profile_column
!           Size allowed for profiles taken simultaneously in a
!           decomposition into columns
      INTEGER &
          l &
!           Loop variable
        , i
!           Loop variable
!     Full clear-sky single-scattering properties
      REAL  (RealK), allocatable :: &
          tau_clr_f(:, :) &
!           Clear-sky optical depth
        , omega_clr_f(:, :) &
!           Clear-sky albedo of single scattering
        , phase_fnc_clr_f(:, :, :)
!           Clear-sky phase function
!
!     Subroutines called:
!      EXTERNAL &
!          two_stream, mix_column, triple_column, calc_flux_ipa &
!        , copy_clr_full
!
!
!
!     Choose an appropriate routine to calculate the fluxes as
!     determined by the cloud scheme selected.
!
      IF (i_cloud == IP_cloud_clear) THEN
!       Allocate and set dynamic arrays.
        ALLOCATE(tau_clr_f(nd_profile, nd_layer))
        ALLOCATE(omega_clr_f(nd_profile, nd_layer))
        ALLOCATE(phase_fnc_clr_f(nd_profile, nd_layer, 1))
!
        CALL copy_clr_full(n_profile, n_layer, n_cloud_top &
          , 1 &
          , ss_prop%tau_clr, ss_prop%omega_clr &
          , ss_prop%phase_fnc_clr &
          , ss_prop%tau, ss_prop%omega, ss_prop%phase_fnc &
          , tau_clr_f, omega_clr_f, phase_fnc_clr_f &
!                       Sizes of arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct, 1 &
          )
!
!       A two-stream scheme with no clouds.
        CALL two_stream(ierr &
!                        Atmospheric properties
          , n_profile, n_layer &
!                        Two-stream scheme
          , i_2stream &
!                        Options for solver
          , i_solver &
!                        Options for equivalent extinction
          , l_scale_solar, adjust_solar_ke &
!                        Spectral region
          , isolir &
!                        Infra-red properties
          , diff_planck &
          , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
          , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                        Surface conditions
          , rho_alb(1, IP_surf_alb_diff) &
          , rho_alb(1, IP_surf_alb_dir), d_planck_flux_surface &
!                        Single scattering properties
          , tau_clr_f, omega_clr_f, phase_fnc_clr_f(1, 1, 1) &
!                        Fluxes calculated
          , flux_direct, flux_total &
!                        Sizes of arrays
          , nd_profile, nd_layer, nd_source_coeff &
          )
!
!       Release temporary storage.
        DEALLOCATE(tau_clr_f)
        DEALLOCATE(omega_clr_f)
        DEALLOCATE(phase_fnc_clr_f)
!
        IF (l_clear) THEN
!         The clear fluxes here can be copied directly without
!         any further calculation.
          IF (isolir == IP_solar) THEN
!           DO i=0, n_layer
!              DO l=1, n_profile
           DO i=0, nd_layer 
              DO l=1, nd_profile 
                flux_direct_clear(l, i)=flux_direct(l, i)
              ENDDO
            ENDDO
          ENDIF
!        DO i=1, 2*n_layer+2
!           DO l=1, n_profile
        DO i=1, 2*nd_layer+2 
           DO l=1, nd_profile 
              flux_total_clear(l, i)=flux_total(l, i)
            ENDDO
          ENDDO
        ENDIF
!
      ELSEIF ( (i_cloud == IP_cloud_mix_max).OR. &
               (i_cloud == IP_cloud_mix_random).OR. &
               ( (i_cloud == IP_cloud_part_corr).AND. &
                 (n_region == 2) ) ) THEN
!
!       Clouds are treated using the coupled overlaps originally
!       introduced by Geleyn and Hollingsworth.
!
        CALL mix_column(ierr &
!                        Atmospheric properties
          , n_profile, n_layer, k_clr &
!                        Two-stream scheme
          , i_2stream &
!                        Options for solver
          , i_solver &
!                        Options for equivalent extinction
          , l_scale_solar, adjust_solar_ke &
!                        Spectral region
          , isolir &
!                        Infra-red properties
          , diff_planck &
          , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
          , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                        Conditions at surface
          , rho_alb(1, IP_surf_alb_diff), rho_alb(1, ip_surf_alb_dir) &
          , d_planck_flux_surface &
!                        Single scattering properties
          , ss_prop &
!                        Cloud geometry
          , n_cloud_top &
          , n_cloud_type, frac_cloud &
          , w_free, w_cloud &
          , cloud_overlap &
!                        Fluxes calculated
          , flux_direct, flux_total &
!                        Flags for clear-sky calculations
          , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
          , flux_direct_clear, flux_total_clear &
!                        Dimensions of arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct &
          , nd_max_order, nd_source_coeff &
          , nd_cloud_type, nd_overlap_coeff &
          )
        IF (ierr /= i_normal) RETURN
!
      ELSEIF ( (i_cloud == IP_cloud_triple).OR. &
               ( (i_cloud == IP_cloud_part_corr_cnv).AND. &
                 (n_region == 3) ) ) THEN
!
!       Clouds are treated using a decomposition of the column
!       into clear-sky, stratiform and convective regions.
!
        CALL triple_column(ierr &
!                        Atmospheric properties
          , n_profile, n_layer &
!                        Two-stream scheme
          , i_2stream &
!                        Options for solver
          , i_solver, i_scatter_method &
!                        Options for equivalent extinction
          , l_scale_solar, adjust_solar_ke &
!                        Spectral region
          , isolir &
!                        Infra-red properties
          , diff_planck &
          , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
          , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                        Conditions at surface
          , rho_alb(1, IP_surf_alb_diff), rho_alb(1, ip_surf_alb_dir) &
          , d_planck_flux_surface &
!                        Single scattering properties
          , ss_prop &
!                        Cloud geometry
          , n_cloud_top &
          , n_cloud_type, frac_cloud &
          , n_region, i_region_cloud, frac_region &
          , w_free, w_cloud &
          , cloud_overlap &
!                        Fluxes calculated
          , flux_direct, flux_total &
!                        Flags for clear-sky calculations
          , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
          , flux_direct_clear, flux_total_clear &
!                        Dimensions of arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct &
          , nd_max_order, nd_source_coeff &
          , nd_cloud_type, nd_region, nd_overlap_coeff &
          )
        IF (ierr /= i_normal) RETURN
!

      ELSEIF (i_cloud == IP_cloud_column_max) THEN
!       Clouds are treated on the assumption of maximum overlap
!       in a column model.






!
!       Set a dimension to allow the subcolumns of several profiles
!       to be considered at once.
        nd_profile_column=max(1, n_profile)
        DO l=1, nd_profile
          nd_profile_column=max(nd_profile_column, n_column_slv(l))
        ENDDO
!
        CALL calc_flux_ipa(ierr &
!                        Atmospheric properties
          , n_profile, n_layer, n_cloud_top &
!                        Options for equivalent extinction
          , l_scale_solar, adjust_solar_ke &
!                        Algorithmic options
          , i_2stream, i_solver &
!                        Spectral region
          , isolir &
!                        Infra-red properties
          , diff_planck &
          , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
          , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                        Conditions at surface
          , d_planck_flux_surface, rho_alb &
!                        Single scattering properties
          , ss_prop &
!                        Cloud geometry
          , n_column_slv, list_column_slv &
          , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                        Fluxes calculated
          , flux_direct, flux_total &
!                        Flags for clear-sky calculations
          , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
          , flux_direct_clear, flux_total_clear &
!                        Dimensions of arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
          , nd_profile_column, nd_source_coeff &
          )
        IF (ierr /= i_normal) RETURN
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE MONOCHROMATIC_RADIANCE_TSEQ
!+ Subroutine to calculate the optical properties of aerosols.
!
! Method:
!       If the optical properties come from an observational
!       distribution a separate subroutine is called. Otherwise
!       appropriate mean quantities in the layer are calculated
!       as the parametrization requires and these values are
!       substituted into the parametrization to give the optical
!       properties. Aerosol properties may depend on the humidity.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE opt_prop_aerosol(ierr &
        , n_profile, first_layer, last_layer &
        , n_order_phase, l_rescale, n_order_forward &
        , l_henyey_greenstein_pf &
        , n_aerosol, aerosol_mix_ratio &
        , i_aerosol_parametrization &
        , i_humidity_pointer, humidities, delta_humidity &
        , mean_rel_humidity &
        , aerosol_absorption, aerosol_scattering, aerosol_phase_fnc &
        , l_solar_phf, n_order_phase_solar, n_direction, cos_sol_view &

        , p, density &
        , n_opt_level_aerosol_prsc, aerosol_pressure_prsc &
        , aerosol_absorption_prsc, aerosol_scattering_prsc &
        , aerosol_phase_fnc_prsc &

        , k_ext_tot, k_ext_scat, phase_fnc, forward_scatter &
        , forward_solar, phase_fnc_solar &
        , nd_profile, nd_radiance_profile, nd_layer, id_lt, id_lb &
        , nd_aerosol_species, nd_humidities &
        , nd_phase_term, nd_max_order, nd_direction &

        , nd_profile_prsc, nd_opt_level_prsc &

        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE aerosol_parametrization_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_radiance_profile &
!           Size allocated for profiles of quantities only
!           required when radiances are wanted
        , nd_layer &
!           Size allocated for layers
        , id_lt &
!           Topmost declared layer for output optical properties
        , id_lb &
!           Bottom declared layer for output optical properties
        , nd_phase_term &
!           Size allocated for terms in phase function
        , nd_max_order &
!           Size allocated for orders of sperical harmonics
        , nd_direction &
!           Size allocated for viewing directions
        , nd_aerosol_species &
!           Size allocated for aerosol species
        , nd_humidities &
!           Size allocated for humidities

        , nd_profile_prsc &
!           Size allowed for profiles of prescribed properties
        , nd_opt_level_prsc
!           Size allowed for levels of prescribed properties

!
!     Inclusion of header files.
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , first_layer &
!           First layer where propeties are required
        , last_layer &
!           Last layer where propeties are required
        , n_order_phase &
!           Number of terms to retain in the phase function
        , n_order_phase_solar &
!           Number of terms to retain in calculating the angular
!           scattering of solar radiation
        , n_direction &
!           Number of viewing directions
        , n_order_forward
!           Order used in forming the forward scattering parameter
!
      LOGICAL, Intent(IN) :: &
          l_rescale &
!           Flag for delta-rescaling
        , l_henyey_greenstein_pf &
!           Flag to use a Henyey-Greenstein phase function
        , l_solar_phf
!           Flag to use calculate a separate solar phase function
!
      INTEGER, Intent(IN) :: &
          n_aerosol &
!           Number of aerosol species
        , i_aerosol_parametrization(nd_aerosol_species) &
!           Parametrizations of aerosols
        , i_humidity_pointer(nd_profile,  nd_layer)
!           Pointer to aerosol look-up table
!
      REAL  (RealK), Intent(IN) :: &
          cos_sol_view(nd_radiance_profile, nd_direction)
!           Cosines of the angles between the solar direction
!           and the viewing direction
!
      REAL  (RealK), Intent(IN) :: &
          aerosol_mix_ratio(nd_profile, nd_layer &
            , nd_aerosol_species) &
!           Number densty of aerosols
        , aerosol_absorption(nd_humidities, nd_aerosol_species) &
!           Aerosol absorption in band/mix ratio
        , aerosol_scattering(nd_humidities, nd_aerosol_species) &
!           Aerosol scattering in band/mix ratio
        , aerosol_phase_fnc(nd_humidities &
            , nd_phase_term, nd_aerosol_species) &
!           Aerosol phase function in band
        , humidities(nd_humidities, nd_aerosol_species) &
!           Array of humidities
        , delta_humidity &
!           Increment in humidity
        , mean_rel_humidity(nd_profile, nd_layer)
!           Mixing ratio of water vapour
!

      INTEGER, Intent(IN) :: &
          n_opt_level_aerosol_prsc(nd_aerosol_species)
!           Number of aerosol data layers
!
      REAL  (RealK), Intent(IN) :: &
          p(nd_profile, nd_layer) &
!           Pressure
        , density(nd_profile, nd_layer) &
!           Atmospheric density
        , aerosol_pressure_prsc(nd_profile_prsc, nd_opt_level_prsc &
            , nd_aerosol_species) &
!           Pressures at levels of prescribed aerosol properties
        , aerosol_absorption_prsc(nd_profile_prsc, nd_opt_level_prsc &
            , nd_aerosol_species) &
!           Prescribed aerosol absorption
        , aerosol_scattering_prsc(nd_profile_prsc, nd_opt_level_prsc &
            , nd_aerosol_species) &
!           Prescribed aerosol scattering
        , aerosol_phase_fnc_prsc(nd_profile_prsc, nd_opt_level_prsc &
            , nd_phase_term, nd_aerosol_species)
!           Prescribed aerosol phase function

      REAL  (RealK), Intent(INOUT) :: &
          k_ext_scat(nd_profile, id_lt: id_lb) &
!           Scattering extinction
        , k_ext_tot(nd_profile, id_lt: id_lb) &
!           Total extinction
        , phase_fnc(nd_profile, id_lt: id_lb, nd_max_order) &
!           Phase function
        , forward_scatter(nd_profile, id_lt: id_lb) &
!           Forward scattering
        , forward_solar(nd_profile, id_lt: id_lb) &
!           Forward scattering for the solar beam
        , phase_fnc_solar(nd_radiance_profile &
            , id_lt: id_lb, nd_direction)
!           Phase function relative to the solar beam
!
!     Local variables.
      LOGICAL &
          l_use_hg_phf &
!           Flag to use Henyey-Greenstein phase functions
        , l_interpolate_hum
!           Flag to interpolate optical properties through a look-up
!           table of humidities
      INTEGER &
          l &
!           Loop variable
        , j &
!           Loop variable
        , i &
!           Loop variable
        , id &
!           Loop variable
        , ls &
!           Loop variable
        , i_pointer
!           Temporary pointer
      REAL  (RealK) :: &
          k_scatter(nd_profile, id_lt: id_lb) &
!           Scattering of current extinction of the current aerosol
        , asymmetry(nd_profile, id_lt: id_lb) &
!           Asymmetry of the current aerosol
        , ks_phf(nd_profile, id_lt: id_lb) &
!           Scattering coefficient multiplied by a coefficient in the
!           phase function
        , phf_coeff(nd_profile, id_lt: id_lb)
!           Coefficient in the phase function of the current aerosol
!
      REAL  (RealK) :: &
          weight_upper(nd_profile, id_lt: id_lb)
!           Weighting towards the upper end of an interval
!           in a look-up table
!

!     Optical properties interpolated from prescribed properties
!     for each component
      REAL  (RealK) :: &
          k_ext_scat_comp(nd_profile, id_lt: id_lb) &
!           Scattering extinction of component
        , k_ext_tot_comp(nd_profile, id_lt: id_lb) &
!           Total extinction of component
        , phase_fnc_comp(nd_profile, id_lt: id_lb, nd_max_order) &
!           Phase function of component
        , phase_fnc_solar_comp(nd_radiance_profile &
            , id_lt: id_lb, nd_direction) &
!           Solar phase function of component
        , forward_scatter_comp(nd_profile, id_lt: id_lb) &
!           Forward scattering of component
        , forward_solar_comp(nd_profile, id_lt: id_lb)
!           Forward scattering of the solar beam for the component

!
!     Legendre polynomials:
      REAL  (RealK) :: &
          cnst1 &
!           Constant in recurrence for Legendre polynomials
        , p_legendre_ls(nd_radiance_profile, id_lt: id_lb) &
!           Legendre polynomial at the current order
        , p_legendre_ls_m1(nd_radiance_profile, id_lt: id_lb) &
!           Legendre polynomial at the previous order
        , p_legendre_tmp(nd_radiance_profile, id_lt: id_lb) &
!           Temporary Legendre polynomial
        , phase_fnc_solar_tmp(nd_radiance_profile, id_lt: id_lb)
!           Current contribution to the solar phase function
!

!     Subroutines called:
!      EXTERNAL &
!         prsc_opt_prop

!
!
!
      DO j=1, n_aerosol
!
!       Use the Henyey-Greenstein phase function if specifically
!       requested, or if using an old parametrization which gives
!       only an asymmetry.
        l_use_hg_phf=l_henyey_greenstein_pf.OR. &
          (i_aerosol_parametrization(j) == IP_aerosol_param_dry).OR. &
          (i_aerosol_parametrization(j) == IP_aerosol_param_moist)
!
!       Interpolate from the look-up table if using moist properties.
        l_interpolate_hum= &
          (i_aerosol_parametrization(j) == IP_aerosol_param_moist).OR. &
          (i_aerosol_parametrization(j) == IP_aerosol_param_phf_moist)
!
        IF ( (i_aerosol_parametrization(j) == &
              IP_aerosol_param_dry).OR. &
             (i_aerosol_parametrization(j) == &
              IP_aerosol_param_phf_dry).OR. &
             (i_aerosol_parametrization(j) == &
              IP_aerosol_param_moist).OR. &
             (i_aerosol_parametrization(j) == &
              IP_aerosol_param_phf_moist) ) THEN
!
!
          IF (l_interpolate_hum) THEN
!
!             Calculate the required weights for interpolation
!             in this layer.
!CDIR COLLAPSE
            DO i=1, nd_layer
              DO l=1, nd_profile
                i_pointer=i_humidity_pointer(l, i)
                weight_upper(l, i)=(mean_rel_humidity(l, i) &
                  -humidities(i_pointer, j)) &
                  /delta_humidity
              ENDDO
            ENDDO
!
!             Interpolate the absorption and scattering.
!CDIR COLLAPSE
            DO i=1, nd_layer
              DO l=1, nd_profile
                i_pointer=i_humidity_pointer(l, i)
                k_ext_tot(l, i)=k_ext_tot(l, i) &
                  +aerosol_mix_ratio(l, i, j) &
                  *(aerosol_absorption(i_pointer, j) &
                  +weight_upper(l, i) &
                  *(aerosol_absorption(i_pointer+1, j) &
                  -aerosol_absorption(i_pointer, j)))
                k_scatter(l, i)=aerosol_mix_ratio(l, i, j) &
                  *(aerosol_scattering(i_pointer, j) &
                  +weight_upper(l, i) &
                  *(aerosol_scattering(i_pointer+1, j) &
                  -aerosol_scattering(i_pointer, j)))
                k_ext_scat(l, i)=k_ext_scat(l, i) &
                  +k_scatter(l, i)
              ENDDO
            ENDDO
!
          ELSE
!
!CDIR COLLAPSE
            DO i=1, nd_layer
              DO l=1, nd_profile
!
!               Calculate volume extinctions directly from the
!               mass extinction coefficients.
                k_ext_tot(l, i)=k_ext_tot(l, i) &
                  +aerosol_mix_ratio(l, i, j) &
                  *aerosol_absorption(1, j)
                k_scatter(l, i)=aerosol_mix_ratio(l, i, j) &
                  *aerosol_scattering(1, j)
                k_ext_scat(l, i)=k_ext_scat(l, i) &
                  +k_scatter(l, i)
!
              ENDDO
            ENDDO
!
          ENDIF
!
!           The phase function:
!
          IF (l_use_hg_phf) THEN
!
!             Note that there is an ambiguity in the definition of a
!             Henyey-Greenstein phase function when humidity is included
!             since one could set up the lookup table externally with
!             all moments at the reference points set to powers of the
!             appropriate asymmetries, but then linear interpolation in
!             the humidity would not give a true Henyey-Greenstein
!             phase function at intermediate points. Here we adopt a
!             true Henyey-Greenstein approach, calculating just the
!             asymmetry.
!
!             Calculate the asymmetry:
            IF (l_interpolate_hum) THEN
!CDIR COLLAPSE
              DO i=1, nd_layer
                DO l=1, nd_profile
                  i_pointer=i_humidity_pointer(l, i)
                  asymmetry(l, i) &
                    =aerosol_phase_fnc(i_pointer, 1, j) &
                    +weight_upper(l, i) &
                    *(aerosol_phase_fnc(i_pointer+1, 1, j) &
                    -aerosol_phase_fnc(i_pointer, 1, j))
                ENDDO
              ENDDO
            ELSE
!CDIR COLLAPSE
              DO i=1, nd_layer
                DO l=1, nd_profile
                  asymmetry(l, i)=aerosol_phase_fnc(1, 1, j)
                ENDDO
              ENDDO
            ENDIF
!
!             Set the lowest order in the phase function (required
!             for two-stream calculations and other quadratures).
!CDIR COLLAPSE
            DO i=1, nd_layer
              DO l=1, nd_profile
                phase_fnc(l, i, 1)=phase_fnc(l, i, 1) &
                  +k_scatter(l, i)*asymmetry(l, i)
              ENDDO
            ENDDO
!
!             Initialize the product of the scattering and the
!             current moment of the phase function. This repeats
!             part of the preceeding loop, but separating it saves
!             an assignment in the case of two-stream calculations.
            IF (l_rescale.OR.(n_order_phase >= 2)) THEN
!CDIR COLLAPSE
              DO i=1, nd_layer
                DO l=1, nd_profile
                  ks_phf(l, i)=k_scatter(l, i)*asymmetry(l, i)
                ENDDO
              ENDDO
            ENDIF
!
!             Calculate weighted higher moments recursively.
            DO ls=2, n_order_phase
!CDIR COLLAPSE
              DO i=1, nd_layer
                DO l=1, nd_profile
                  ks_phf(l,i )=ks_phf(l, i)*asymmetry(l, i)
                  phase_fnc(l, i, ls) &
                    =phase_fnc(l, i, ls)+ks_phf(l, i)
                ENDDO
              ENDDO
            ENDDO
!
!             Usually, we will retain terms as far as the order of
!             truncation, but in the case of two-stream methods the
!             order of truncation will exceed the order of retention
!             by 1.
            IF (l_rescale) THEN
!
              IF (n_order_forward == n_order_phase) THEN
!CDIR COLLAPSE
                DO i=1, nd_layer
                  DO l=1, nd_profile
                    forward_scatter(l, i) &
                      =forward_scatter(l, i)+ks_phf(l, i)
                  ENDDO
                ENDDO
              ELSE IF (n_order_forward == n_order_phase+1) THEN
!CDIR COLLAPSE
                DO i=1, nd_layer
                  DO l=1, nd_profile
                    forward_scatter(l, i) &
                      =forward_scatter(l, i)+ks_phf(l, i)*asymmetry(l, i)
                  ENDDO
                ENDDO
              ELSE
!                 This case probably shouldn''t arise so we use
!                 inefficient explicit exponentiation.
!CDIR COLLAPSE
                DO i=1, nd_layer
                  DO l=1, nd_profile
                    forward_scatter(l, i) &
                      =forward_scatter(l, i) &
                      +k_scatter(l, i)*asymmetry(l, i)**n_order_forward
                  ENDDO
                ENDDO
              ENDIF
!
            ENDIF
!
!
          ELSE
!
!             Calculate the phase function generally. We don''t
!             separate the first order here, because it is unlikely
!             that this block will be used in the case in a
!             two-stream calculation.
            DO ls=1, n_order_phase
              IF (l_interpolate_hum) THEN
!CDIR COLLAPSE
                DO i=1, nd_layer
                  DO l=1, nd_profile
                    i_pointer=i_humidity_pointer(l, i)
                    phf_coeff(l, i)=aerosol_phase_fnc(i_pointer, ls, j) &
                      +weight_upper(l, i) &
                      *(aerosol_phase_fnc(i_pointer+1, ls, j) &
                      -aerosol_phase_fnc(i_pointer, ls, j))
                  ENDDO
                ENDDO
              ELSE
!CDIR COLLAPSE
                DO i=1, nd_layer
                  DO l=1, nd_profile
                    phf_coeff(l, i)=aerosol_phase_fnc(1, ls, j)
                  ENDDO
                ENDDO
              ENDIF
!CDIR COLLAPSE
              DO i=1, nd_layer
                DO l=1, nd_profile
                  phase_fnc(l, i, ls)=phase_fnc(l, i, ls) &
                    +k_scatter(l, i)*phf_coeff(l, i)
                ENDDO
              ENDDO
            ENDDO
!
            IF (l_rescale) THEN
              IF (l_interpolate_hum) THEN
!CDIR COLLAPSE
                DO i=1, nd_layer
                  DO l=1, nd_profile
                    i_pointer=i_humidity_pointer(l, i)
                    phf_coeff(l, i) &
                      =aerosol_phase_fnc(i_pointer, n_order_forward, j) &
                      +weight_upper(l, i) &
                      *(aerosol_phase_fnc(i_pointer+1 &
                      , n_order_forward, j) &
                      -aerosol_phase_fnc(i_pointer &
                      , n_order_forward, j))
                  ENDDO
                ENDDO
              ELSE
!CDIR COLLAPSE
                DO i=1, nd_layer
                  DO l=1, nd_profile
                    phf_coeff(l, i) &
                      =aerosol_phase_fnc(1, n_order_forward, j)
                  ENDDO
                ENDDO
              ENDIF
!CDIR COLLAPSE
              DO i=1, nd_layer
                DO l=1, nd_profile
                  forward_scatter(l, i) &
                    =forward_scatter(l, i) &
                    +k_scatter(l, i)*phf_coeff(l, i)
                ENDDO
              ENDDO
            ENDIF
          ENDIF
!
!PROBLEMA
          DO i=first_layer, last_layer
            IF (l_solar_phf) THEN
!             Calculate the solar phase function to higher accuracy.
              DO id=1, n_direction
!               The Legendre polynomials are not stored so as to reduce
!               the requirement for memory at very high orders of solar
!               truncation.
                IF (l_interpolate_hum) THEN
                  DO l=1, n_profile
                    i_pointer=i_humidity_pointer(l, i)
                    phf_coeff(l, i)=aerosol_phase_fnc(i_pointer, 1, j) &
                      +weight_upper(l, i) &
                      *(aerosol_phase_fnc(i_pointer+1, 1, j) &
                      -aerosol_phase_fnc(i_pointer, 1, j))
                  ENDDO
                ELSE
                  DO l=1, n_profile
                    phf_coeff(l, i)=aerosol_phase_fnc(1, 1, j)
                  ENDDO
                ENDIF
                DO l=1, n_profile
!                 Initialize the Legendre polynomials at the zeroth and
!                 first orders.
                  p_legendre_ls_m1(l, i)=1.0e+00_RealK
                  p_legendre_ls(l, i)=cos_sol_view(l, id)
                  phase_fnc_solar_tmp(l, i)=1.0e+00_RealK+phf_coeff(l, i) &
                    *p_legendre_ls(l, i)*real(2*1+1, RealK)
                ENDDO
!
                IF (l_use_hg_phf) THEN
!                 Store the asymmetry in this case.
                  DO l=1, n_profile
                    asymmetry(l, i)=phf_coeff(l, i)
                  ENDDO
                ENDIF
!
                DO ls=2, n_order_phase_solar
!                 Calculate higher orders by recurrences.
                  cnst1=1.0e+00_RealK-1.0e+00_realk/real(ls, realk)
                  DO l=1, n_profile
                    p_legendre_tmp(l, i)=p_legendre_ls(l, i)
                    p_legendre_ls(l, i) &
                      =(1.0e+00_RealK+cnst1)*p_legendre_ls(l, i) &
                      *cos_sol_view(l, id)-cnst1*p_legendre_ls_m1(l, i)
                    p_legendre_ls_m1(l, i)=p_legendre_tmp(l, i)
                  ENDDO
!
!                 Calculate the next moment of the phase function.
                  IF (l_use_hg_phf) THEN
                    DO l=1, n_profile
                      phf_coeff(l, i)=phf_coeff(l, i)*asymmetry(l, i)
                    ENDDO
                  ELSE
                    IF (l_interpolate_hum) THEN
                      DO l=1, n_profile
                        i_pointer=i_humidity_pointer(l, i)
                        phf_coeff(l, i) &
                          =aerosol_phase_fnc(i_pointer, ls, j) &
                          +weight_upper(l, i) &
                          *(aerosol_phase_fnc(i_pointer+1, ls, j) &
                          -aerosol_phase_fnc(i_pointer, ls, j))
                      ENDDO
                    ELSE
                      DO l=1, n_profile
                        phf_coeff(l, i)=aerosol_phase_fnc(1, ls, j)
                      ENDDO
                    ENDIF
                  ENDIF
                  DO l=1, n_profile
                    phase_fnc_solar_tmp(l, i)=phase_fnc_solar_tmp(l, i) &
                      +phf_coeff(l, i) &
                      *real(2*ls+1, RealK)*p_legendre_ls(l, i)
                  ENDDO
                ENDDO
!               Increment the stored phase function.
                DO l=1, n_profile
                  phase_fnc_solar(l, i, id) &
                    =phase_fnc_solar(l, i, id) &
                  +k_scatter(l, i)*phase_fnc_solar_tmp(l, i)
                ENDDO
              ENDDO
!
!             Continue to an extra order to find the rescaling
!             for the solar beam.
              IF (l_rescale) THEN
                IF (l_use_hg_phf) THEN
                  DO l=1, n_profile
                    phf_coeff(l, i)=phf_coeff(l, i)*asymmetry(l, i)
                  ENDDO
                ELSE
                  ls=n_order_phase_solar+1
                  IF (l_interpolate_hum) THEN
                    DO l=1, n_profile
                      i_pointer=i_humidity_pointer(l, i)
                      phf_coeff(l, i) &
                        =aerosol_phase_fnc(i_pointer, ls, j) &
                        +weight_upper(l, i) &
                        *(aerosol_phase_fnc(i_pointer+1, ls, j) &
                        -aerosol_phase_fnc(i_pointer, ls, j))
                    ENDDO
                  ELSE
                    DO l=1, n_profile
                      phf_coeff(l, i)=aerosol_phase_fnc(1, ls, j)
                    ENDDO
                  ENDIF
                ENDIF
                DO l=1, n_profile
                  forward_solar(l, i)=forward_solar(l, i) &
                    +k_scatter(l, i)*phf_coeff(l, i)
                ENDDO
              ENDIF
!
            ENDIF
!
          ENDDO
!
!
!

        ELSE IF (i_aerosol_parametrization(j) == &
                 IP_aerosol_unparametrized) THEN
!
           CALL prsc_opt_prop(ierr &
             , n_profile, first_layer, last_layer &
             , l_rescale, n_order_forward &
             , l_henyey_greenstein_pf, n_order_phase &
             , p, density &
             , n_opt_level_aerosol_prsc(j) &
             , aerosol_pressure_prsc(1, 1, j) &
             , aerosol_absorption_prsc(1, 1, j) &
             , aerosol_scattering_prsc(1, 1, j) &
             , aerosol_phase_fnc_prsc(1, 1, 1, j) &
             , k_ext_tot_comp, k_ext_scat_comp, phase_fnc_comp &
             , forward_scatter_comp, forward_solar_comp &
             , l_solar_phf, n_order_phase_solar &
             , n_direction, cos_sol_view &
             , phase_fnc_solar_comp &
             , nd_profile, nd_radiance_profile, nd_layer &
             , id_lt, id_lb &
             , nd_direction &
             , nd_profile_prsc, nd_opt_level_prsc &
             , nd_phase_term, nd_max_order &
             )
!
          DO i=first_layer, last_layer
            DO l=1, n_profile
              k_ext_tot(l, i)=k_ext_tot(l, i) &
                +k_ext_tot_comp(l, i)
              k_ext_scat(l, i)=k_ext_scat(l, i) &
                +k_ext_scat_comp(l, i)
            ENDDO
          ENDDO
          DO ls=1, n_order_phase
            DO i=first_layer, last_layer
              DO l=1, n_profile
                phase_fnc(l, i, ls)=phase_fnc(l, i, ls) &
                  +phase_fnc_comp(l, i, ls)
              ENDDO
            ENDDO
          ENDDO
          IF (l_rescale) THEN
            DO i=first_layer, last_layer
              DO l=1, n_profile
                forward_scatter(l, i)=forward_scatter(l, i) &
                  +forward_scatter_comp(l, i)
              ENDDO
            ENDDO
          ENDIF
          IF (l_solar_phf) THEN
            IF (l_rescale) THEN
              DO i=first_layer, last_layer
                DO l=1, n_profile
                  forward_solar(l, i)=forward_solar(l, i) &
                    +forward_solar_comp(l, i)
                ENDDO
              ENDDO
            ENDIF
            DO id=1, n_direction
              DO i=first_layer, last_layer
                DO l=1, n_profile
                  phase_fnc_solar(l, i, id) &
                    =phase_fnc_solar(l, i, id) &
                    +phase_fnc_solar_comp(l, i, id)
                ENDDO
              ENDDO
            ENDDO
          ENDIF
!

        ELSE
!
          WRITE(iu_err, '(/a, i3, a)') &
            '*** Error: i_aerosol_parametrization for species ' &
            , j, ' has been set to an illegal value.'
          ierr=i_err_fatal
          RETURN
!
        ENDIF
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE OPT_PROP_AEROSOL
!+ Subroutine to calculate optical properties of ice clouds.
!
! Method:
!        If the optical properties come from an observational
!        distribution a separate subroutine is called. Otherwise
!        appropriate mean quantities in the layer are calculated
!        as the parametrization requires and these values are
!        substituted into the parametrization to give the optical
!        properties.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE opt_prop_ice_cloud(ierr &
        , n_profile, n_layer, n_cloud_top &
        , n_cloud_profile, i_cloud_profile &
        , n_order_phase, l_rescale, n_order_forward &
        , l_henyey_greenstein_pf, l_solar_phf, n_order_phase_solar &
        , n_direction, cos_sol_view &
        , i_parametrization_ice, ice_cloud_parameter &
        , ice_mass_frac, dim_char_ice &
        , p, t, density &
        , n_opt_level_cloud_prsc, ice_pressure_prsc &
        , ice_absorption_prsc, ice_scattering_prsc &
        , ice_phase_fnc_prsc &




        , k_ext_tot_cloud, k_ext_scat_cloud &
        , phase_fnc_cloud, forward_scatter_cloud &
        , forward_solar_cloud, phase_fnc_solar_cloud &
        , nd_profile, nd_radiance_profile, nd_layer, id_ct &
        , nd_direction, nd_phase_term, nd_max_order &
        , nd_cloud_parameter &

        , nd_profile_prsc, nd_opt_level_prsc &

        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE ice_cloud_parametrization_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_radiance_profile &
!           Size allocated for points where radiances are calculated
        , nd_layer &
!           Size allocated for layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_direction &
!           Size allocated for viewing directions
        , nd_cloud_parameter &
!           Size allocated for cloud parameters
        , nd_phase_term &
!           Size allocated for terms in the phase function
        , nd_max_order &
!           Size allocated for orders of spherical harmonics

        , nd_profile_prsc &
!           Size allowed for profiles of prescribed optical properties
        , nd_opt_level_prsc
!           Size allowed for levels of prescribed optical properties

!
!     Inclusion of header files.
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_order_phase &
!           Order of the phase function
        , n_order_phase_solar &
!           Number of terms to retain in single scattered solar
!           phase function
        , n_order_forward &
!           Order used in forming the forward scattering parameter
        , n_cloud_top &
!           Topmost cloudy layer
        , i_parametrization_ice &
!           Treatment of ice crystals

        , n_opt_level_cloud_prsc &
!           Number of levels of prescribed data

        , n_cloud_profile(id_ct: nd_layer) &
!           Number of cloudy profiles
        , i_cloud_profile(nd_profile, id_ct: nd_layer)
!           Profiles containing clouds
      LOGICAL, Intent(IN) :: &
          l_rescale &
!           Delta-rescaling required
        , l_henyey_greenstein_pf &
!           Flag to use a Henyey-Greenstein phase function
        , l_solar_phf
!           Flag to use an extended solar phase function in
!           single scattering
!
!     Viewing directions:
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing dierctions
      REAL  (RealK), Intent(IN) :: &
          cos_sol_view(nd_radiance_profile, nd_direction)
!           Cosines of the angles between the solar direction
!           and the viewing direction
!
      REAL  (RealK), Intent(IN) :: &
          ice_cloud_parameter(nd_cloud_parameter) &
!           Ice cloud parameters
        , ice_mass_frac(nd_profile, id_ct: nd_layer) &
!           Ice mass fraction
        , dim_char_ice(nd_profile, id_ct: nd_layer) &
!           Characteristic dimension for crystals
        , t(nd_profile, nd_layer) &
!           Temperature
        , density(nd_profile, nd_layer)
!           Atmospheric density

      REAL  (RealK), Intent(IN) :: &
          p(nd_profile, nd_layer) &
!           Pressure
        , ice_pressure_prsc(nd_profile_prsc, nd_opt_level_prsc) &
!           Pressure at which optical properties are prescribed
        , ice_absorption_prsc(nd_profile_prsc, nd_opt_level_prsc) &
!           Prescribed absorption by ice crystals
        , ice_scattering_prsc(nd_profile_prsc, nd_opt_level_prsc) &
!           Prescribed absorption by ice crystals
        , ice_phase_fnc_prsc(nd_profile_prsc, nd_opt_level_prsc &
            , nd_phase_term)
!           Prescribed phase functions of ice crystals

      REAL  (RealK), Intent(OUT) :: &
          k_ext_scat_cloud(nd_profile, id_ct: nd_layer) &
!           Scattering extinction
        , k_ext_tot_cloud(nd_profile, id_ct: nd_layer) &
!           Total extinction
        , phase_fnc_cloud(nd_profile, id_ct: nd_layer, nd_max_order) &
!           Cloudy phase function
        , phase_fnc_solar_cloud(nd_radiance_profile, id_ct: nd_layer &
            , nd_direction) &
!           Cloudy phase function for singly scattered solar radiation
        , forward_scatter_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy forward scattering
        , forward_solar_cloud(nd_profile, id_ct: nd_layer)
!           Cloudy forward scattering for the solar beam
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , ll &
!           Loop variable
        , i &
!           Loop variable
        , id &
!           Loop variable
        , ls
!           Loop variable
      REAL  (RealK) :: &
          asymmetry_process(nd_profile, id_ct: nd_layer) &
!           Asymmetry factor for current process
        , omega &
!           Albedo of single scattering for the current process
        , x &
!           Temporary algebraic variable
        , y &
!           Temporary algebraic variable
        , t_celsius &
!           Temperature in celsius
        , temp_correction &
!           Temperature correction
        , phf_tmp
!           Temporary phase function
!
!     Legendre polynomials:
      REAL  (RealK) :: &
          cnst1 &
!           Constant in recurrence for Legendre polynomials
        , p_legendre_ls(nd_radiance_profile) &
!           Legendre polynomial at the current order
        , p_legendre_ls_m1(nd_radiance_profile) &
!           Legendre polynomial at the previous order
        , p_legendre_tmp(nd_radiance_profile) &
!           Temporary Legendre polynomial
        , ks_phf(nd_radiance_profile)
!           Product of the scattering and the current moment of
!           the phase function
!

!     Subroutines called:
!      EXTERNAL &
!          prsc_opt_prop

!
!
!
      IF ( (i_parametrization_ice == IP_slingo_schrecker_ice).OR. &
           (i_parametrization_ice == IP_ice_adt).OR. &
           (i_parametrization_ice == IP_ice_adt_10).OR. &
           (i_parametrization_ice == IP_ice_fu_solar).OR. &
           (i_parametrization_ice == IP_ice_fu_ir).OR. &
           (i_parametrization_ice == IP_sun_shine_vn2_ir).OR. &
           (i_parametrization_ice == IP_sun_shine_vn2_ir).OR. &
           ( l_henyey_greenstein_pf .AND. &
             (i_parametrization_ice == IP_slingo_schr_ice_phf) ).OR. &
           ( l_henyey_greenstein_pf .AND. &
             (i_parametrization_ice == IP_ice_fu_phf) ) ) THEN
!
!       Optical properties are calculated from parametrized data.
!
!hmjb        DO i=n_cloud_top, n_layer
!hmjb!
!hmjb!         To avoid the repetition of blocks of code or excessive
!hmjb!         use of memory it is easiest to have an outer loop over
!hmjb!         layers.
!
!
        SELECT CASE(i_parametrization_ice)
!
        CASE(IP_slingo_schrecker_ice, ip_slingo_schr_ice_phf)
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              k_ext_tot_cloud(l, i) &
                =ice_mass_frac(l, i)*(ice_cloud_parameter(1) &
                +ice_cloud_parameter(2)/dim_char_ice(l, i))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0_RealK-ice_cloud_parameter(3) &
              -ice_cloud_parameter(4)*dim_char_ice(l, i))
              asymmetry_process(l, i) &
                =ice_cloud_parameter(5)+ice_cloud_parameter(6) &
                *dim_char_ice(l, i)
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        CASE (IP_ice_adt)
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              x=log(dim_char_ice(l, i)/ice_cloud_parameter(10))
              IF (x > 0.0_RealK) THEN
!               Large mode.
                k_ext_tot_cloud(l, i)=ice_mass_frac(l, i) &
                  *exp(ice_cloud_parameter(1) &
                  +x*(ice_cloud_parameter(2) &
                  +x*(ice_cloud_parameter(3) &
                  +x*(ice_cloud_parameter(4) &
                  +x*ice_cloud_parameter(5)))))
              ELSE IF (x <= 0.0_RealK) THEN
!               Small mode.
                k_ext_tot_cloud(l, i)=ice_mass_frac(l, i) &
                  *exp(ice_cloud_parameter(1) &
                  +x*(ice_cloud_parameter(6) &
                  +x*(ice_cloud_parameter(7) &
                  +x*(ice_cloud_parameter(8) &
                  +x*ice_cloud_parameter(9)))))
              ENDIF
              x=log(dim_char_ice(l, i)/ice_cloud_parameter(20))
              IF (x > 0.0_RealK) THEN
!               Large mode.
                k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                  *(1.0_RealK-(ice_cloud_parameter(11) &
                  +x*(ice_cloud_parameter(12) &
                  +x*(ice_cloud_parameter(13) &
                  +x*(ice_cloud_parameter(14) &
                  +x*ice_cloud_parameter(15))))))
              ELSE IF (x <= 0.0_RealK) THEN
!               Small mode.
                k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                  *(1.0_RealK-(ice_cloud_parameter(11) &
                  +x*(ice_cloud_parameter(16) &
                  +x*(ice_cloud_parameter(17) &
                  +x*(ice_cloud_parameter(18) &
                  +x*ice_cloud_parameter(19))))))
              ENDIF
              x=log(dim_char_ice(l, i)/ice_cloud_parameter(30))
              IF (x > 0.0_RealK) THEN
!               Large mode.
                asymmetry_process(l, i)=ice_cloud_parameter(21) &
                  +x*(ice_cloud_parameter(22) &
                  +x*(ice_cloud_parameter(23) &
                  +x*(ice_cloud_parameter(24) &
                  +x*ice_cloud_parameter(25))))
              ELSE IF (x <= 0.0_RealK) THEN
!               Small mode.
                asymmetry_process(l, i)=ice_cloud_parameter(21) &
                  +x*(ice_cloud_parameter(26) &
                  +x*(ice_cloud_parameter(27) &
                  +x*(ice_cloud_parameter(28) &
                  +x*ice_cloud_parameter(29))))
              ENDIF
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        CASE(IP_ice_adt_10)
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              x=dim_char_ice(l, i)/ice_cloud_parameter(12)
              y=ice_cloud_parameter(6) &
                +x*(ice_cloud_parameter(7) &
                +x*(ice_cloud_parameter(8) &
                +x*(ice_cloud_parameter(9) &
                +x*(ice_cloud_parameter(10) &
                +x*ice_cloud_parameter(11)))))
              k_ext_tot_cloud(l, i)=ice_mass_frac(l, i) &
                *exp(ice_cloud_parameter(1) &
                +x*(ice_cloud_parameter(2) &
                +x*(ice_cloud_parameter(3) &
                +x*(ice_cloud_parameter(4) &
                +x*(ice_cloud_parameter(5) &
                +x*y)))))
              x=dim_char_ice(l, i)/ice_cloud_parameter(24)
              y=ice_cloud_parameter(18) &
                +x*(ice_cloud_parameter(19) &
                +x*(ice_cloud_parameter(20) &
                +x*(ice_cloud_parameter(21) &
                +x*(ice_cloud_parameter(22) &
                +x*ice_cloud_parameter(23)))))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0_RealK-(ice_cloud_parameter(13) &
                +x*(ice_cloud_parameter(14) &
                +x*(ice_cloud_parameter(15) &
                +x*(ice_cloud_parameter(16) &
                +x*(ice_cloud_parameter(17) &
                +x*y))))))
              x=dim_char_ice(l, i)/ice_cloud_parameter(36)
              y=ice_cloud_parameter(30) &
                +x*(ice_cloud_parameter(31) &
                +x*(ice_cloud_parameter(32) &
                +x*(ice_cloud_parameter(33) &
                +x*(ice_cloud_parameter(34) &
                +x*ice_cloud_parameter(35)))))
              asymmetry_process(l, i)=ice_cloud_parameter(25) &
                +x*(ice_cloud_parameter(26) &
                +x*(ice_cloud_parameter(27) &
                +x*(ice_cloud_parameter(28) &
                +x*(ice_cloud_parameter(29) &
                +x*y))))
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        CASE (IP_sun_shine_vn2_vis)
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              t_celsius=t(l, i)-2.7316e+02_RealK
              temp_correction=1.047_RealK &
                +t_celsius*(-9.13e-05_RealK+t_celsius &
                *(2.026e-04_RealK-1.056e-05_realk*t_celsius))
              k_ext_tot_cloud(l, i)=temp_correction*ice_mass_frac(l, i) &
                /(3.05548e-02_RealK &
                +2.54802e+02_RealK*density(l, i)*ice_mass_frac(l, i))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0_RealK-ice_cloud_parameter(1) &
                *exp(ice_cloud_parameter(2) &
                *log(density(l, i)*ice_mass_frac(l, i)+1.0e-12_RealK))) &
                *(1.0_RealK+ice_cloud_parameter(5) &
                *(temp_correction-1.0_RealK)/temp_correction)
              asymmetry_process(l, i) &
                =ice_cloud_parameter(3)*exp(ice_cloud_parameter(4) &
                *log(density(l, i)*ice_mass_frac(l, i)+1.0e-12_RealK)) &
                *(1.0_RealK+ice_cloud_parameter(6) &
                *(temp_correction-1.0_RealK)/temp_correction)
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        CASE(IP_sun_shine_vn2_ir)
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              t_celsius=t(l, i)-2.7316e+02_RealK
              temp_correction=1.047_RealK+t_celsius &
                *(-9.13e-05_RealK+t_celsius &
                *(2.026e-04_RealK-1.056e-05_realk*t_celsius))
              k_ext_tot_cloud(l, i)=temp_correction*ice_mass_frac(l, i) &
                /(6.30689e-02_RealK &
                +2.65874e+02_RealK*density(l, i)*ice_mass_frac(l, i))
            ENDDO
          ENDDO
!
!
        CASE(IP_ice_fu_solar)
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              k_ext_tot_cloud(l, i) &
                =ice_mass_frac(l, i)*(ice_cloud_parameter(1) &
                +ice_cloud_parameter(2)/dim_char_ice(l, i))
              omega=1.0_RealK-(ice_cloud_parameter(3) &
                +dim_char_ice(l, i)*(ice_cloud_parameter(4) &
                +dim_char_ice(l, i)*(ice_cloud_parameter(5) &
                +dim_char_ice(l, i)*ice_cloud_parameter(6))))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i)*omega
              asymmetry_process(l, i) &
                =ice_cloud_parameter(7)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(8)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(9)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(10))))
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
!             The forward scattering will be limited later.
              forward_scatter_cloud(l, i)=k_ext_scat_cloud(l, i) &
                *(1.0_RealK &
                /max(1.0_RealK, 2.0_realk*omega) &
                +ice_cloud_parameter(11)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(12)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(13)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(14)))))
            ENDDO
          ENDDO
!
!
        CASE(IP_ice_fu_ir)
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              k_ext_tot_cloud(l, i)=ice_mass_frac(l, i) &
                *((ice_cloud_parameter(3)/dim_char_ice(l, i) &
                +ice_cloud_parameter(2))/dim_char_ice(l, i) &
                +ice_cloud_parameter(1))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                -(ice_mass_frac(l, i)/dim_char_ice(l, i)) &
                *(ice_cloud_parameter(4)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(5)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(6)+dim_char_ice(l, i) &
                *ice_cloud_parameter(7))))
              asymmetry_process(l, i) &
                =ice_cloud_parameter(8)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(9)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(10)+dim_char_ice(l, i) &
                *(ice_cloud_parameter(11))))
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        CASE(IP_ice_fu_phf)
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              x=dim_char_ice(l, i)/ice_cloud_parameter(4)
              k_ext_tot_cloud(l, i)=ice_mass_frac(l, i) &
                *((ice_cloud_parameter(3)/x &
                +ice_cloud_parameter(2))/x &
                +ice_cloud_parameter(1))
              x=dim_char_ice(l, i)/ice_cloud_parameter(9)
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0_RealK &
                -(ice_cloud_parameter(5)+x &
                *(ice_cloud_parameter(6)+x &
                *(ice_cloud_parameter(7)+x &
                *ice_cloud_parameter(8)))))
              x=dim_char_ice(l, i)/ice_cloud_parameter(14)
              asymmetry_process(l, i)=ice_cloud_parameter(10) &
                +x*(ice_cloud_parameter(11) &
                +x*(ice_cloud_parameter(12) &
                +x*ice_cloud_parameter(13)))
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        END SELECT
!
!
!         Parametrizations which do not include explicit
!         representation of the higher moments are extended using the
!         Henyey-Greenstein phase function.
!
        DO ls=2, n_order_phase
!CDIR COLLAPSE
          DO i=id_ct, nd_layer 
            DO l=1, nd_profile
              phase_fnc_cloud(l, i, ls) &
                =phase_fnc_cloud(l, i, ls-1)*asymmetry_process(l, i)
            ENDDO
          ENDDO
        ENDDO
!
        IF (l_rescale) THEN
!
!           For most parameterizations the forward scattering
!           is determined from the asymmetry, but in the case of
!           Fu''s parametrization it is defined specially, but must
!           be limited to avoid negative moments in the phase function.
          IF (i_parametrization_ice == IP_ice_fu_solar) THEN
!CDIR COLLAPSE
            DO i=id_ct, nd_layer 
              DO l=1, nd_profile
                forward_scatter_cloud(l, i) &
                  =min(forward_scatter_cloud(l, i) &
                  , k_ext_scat_cloud(l, i) &
                  *asymmetry_process(l, i)**(n_order_forward-1))
              ENDDO
            ENDDO
          ELSE
!CDIR COLLAPSE
            DO i=id_ct, nd_layer 
              DO l=1, nd_profile
                forward_scatter_cloud(l, i) &
                  =k_ext_scat_cloud(l, i) &
                  *asymmetry_process(l, i)**n_order_forward
              ENDDO
            ENDDO
          ENDIF
        ENDIF
!
!hmjb == PROBLEM, THIS PART IS NOT FOLLOWING THE NEW CODE ABOVE!
        IF (l_solar_phf) THEN
          DO i=n_cloud_top, n_layer
!           Calculate the solar phase function to higher accuracy.
            DO id=1, n_direction
!             The Legendre polynomials are not stored so as to reduce
!             the requirement for memory at very high orders of solar
!             truncation.
              DO ll=1, n_cloud_profile(i)
                l=i_cloud_profile(ll, i)
!               Initialize the Legendre polynomials at the zeroth and
!               first orders.
                p_legendre_ls_m1(l)=1.0_RealK
                p_legendre_ls(l)=cos_sol_view(l, id)
                ks_phf(l)=k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
                phase_fnc_solar_cloud(l, i, id)=k_ext_scat_cloud(l, i) &
                  +ks_phf(l)*p_legendre_ls(l)*real(2*1+1, RealK)
              ENDDO
              DO ls=2, n_order_phase_solar
!               Calculate higher orders by recurrences.
                cnst1=1.0_RealK-1.0_realk/real(ls, realk)
                DO ll=1, n_cloud_profile(i)
                  l=i_cloud_profile(ll, i)
                  p_legendre_tmp(l)=p_legendre_ls(l)
                  p_legendre_ls(l) &
                    =(1.0_RealK+cnst1)*p_legendre_ls(l) &
                    *cos_sol_view(l, id)-cnst1*p_legendre_ls_m1(l)
                  p_legendre_ls_m1(l)=p_legendre_tmp(l)
                  ks_phf(l)=ks_phf(l)*asymmetry_process(l, i)
                  phase_fnc_solar_cloud(l, i, id) &
                    =phase_fnc_solar_cloud(l, i, id) &
                    +ks_phf(l)*p_legendre_ls(l) &
                    *real(2*ls+1, RealK)
                ENDDO
              ENDDO
            ENDDO
!
!           Continue to an extra order to find the rescaling
!           for the solar beam.
            IF (l_rescale) THEN
              DO ll=1, n_cloud_profile(i)
                l=i_cloud_profile(ll, i)
                forward_solar_cloud(l, i) &
                  =ks_phf(l)*asymmetry_process(l, i)
              ENDDO
            ENDIF
!
          ENDDO
!
        ENDIF
!
      ELSE IF ( .NOT.l_henyey_greenstein_pf .AND. &
           ( (i_parametrization_ice == IP_slingo_schr_ice_phf).OR. &
             (i_parametrization_ice == IP_ice_fu_phf) ) ) THEN
!
!hmjb        DO i=n_cloud_top, n_layer
!hmjb!
!hmjb!         To avoid the repetition of blocks of code or excessive
!hmjb!         use of memory it is easiest to have an outer loop over
!hmjb!         layers.
!
!
        IF (i_parametrization_ice == IP_slingo_schr_ice_phf) THEN
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer 
            DO l=1, nd_profile
              k_ext_tot_cloud(l, i) &
                =ice_mass_frac(l, i)*(ice_cloud_parameter(1) &
                +ice_cloud_parameter(2)/dim_char_ice(l, i))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0_RealK-ice_cloud_parameter(3) &
              -ice_cloud_parameter(4)*dim_char_ice(l, i))
            ENDDO
          ENDDO
          DO ls=1, n_order_phase
!CDIR COLLAPSE
            DO i=id_ct, nd_layer 
              DO l=1, nd_profile
                phase_fnc_cloud(l, i, ls) &
                  =k_ext_scat_cloud(l, i)*(ice_cloud_parameter(2*ls+3) &
                  +ice_cloud_parameter(2*ls+4)*dim_char_ice(l, i))
              ENDDO
            ENDDO
          ENDDO
          ls=n_order_forward
!CDIR COLLAPSE
          DO i=id_ct, nd_layer 
            DO l=1, nd_profile
              forward_scatter_cloud(l, i) &
                =k_ext_scat_cloud(l, i)*(ice_cloud_parameter(2*ls+3) &
                +ice_cloud_parameter(2*ls+4)*dim_char_ice(l, i))
            ENDDO
          ENDDO
!
        ELSE IF (i_parametrization_ice == IP_ice_fu_phf) THEN
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer 
            DO l=1, nd_profile
              x=dim_char_ice(l, i)/ice_cloud_parameter(4)
              k_ext_tot_cloud(l, i)=ice_mass_frac(l, i) &
                *((ice_cloud_parameter(3)/x &
                +ice_cloud_parameter(2))/x &
                +ice_cloud_parameter(1))
              x=dim_char_ice(l, i)/ice_cloud_parameter(9)
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0_RealK &
                -(ice_cloud_parameter(5)+x &
                *(ice_cloud_parameter(6)+x &
                *(ice_cloud_parameter(7)+x &
                *ice_cloud_parameter(8)))))
            ENDDO
          ENDDO
          DO ls=1, n_order_phase
!CDIR COLLAPSE
            DO i=id_ct, nd_layer 
              DO l=1, nd_profile
                x=dim_char_ice(l, i)/ice_cloud_parameter(5*ls+9)
                phase_fnc_cloud(l, i, ls) &
                  =k_ext_scat_cloud(l, i)*(ice_cloud_parameter(5*ls+5) &
                  +x*(ice_cloud_parameter(5*ls+6) &
                  +x*(ice_cloud_parameter(5*ls+7) &
                  +x*ice_cloud_parameter(5*ls+8))))
              ENDDO
            ENDDO
          ENDDO
          ls=n_order_forward
!CDIR COLLAPSE
          DO i=id_ct, nd_layer 
            DO l=1, nd_profile
              x=dim_char_ice(l, i)/ice_cloud_parameter(5*ls+9)
              forward_scatter_cloud(l, i) &
                =k_ext_scat_cloud(l, i)*(ice_cloud_parameter(5*ls+5) &
                +x*(ice_cloud_parameter(5*ls+6) &
                +x*(ice_cloud_parameter(5*ls+7) &
                +x*ice_cloud_parameter(5*ls+8))))
            ENDDO
          ENDDO
!
        ENDIF
!
!
!hmjb == PROBLEM, THIS PART IS NOT FOLLOWING THE NEW CODE ABOVE!
        IF (l_solar_phf) THEN
          DO i=n_cloud_top, n_layer
!           Calculate the solar phase function to higher accuracy.
            DO id=1, n_direction
!             The Legendre polynomials are not stored so as to reduce
!             the requirement for memory at very high orders of solar
!             truncation.
              DO ll=1, n_cloud_profile(i)
                l=i_cloud_profile(ll, i)
!               Initialize the Legendre polynomials at the zeroth and
!               first orders.
                p_legendre_ls_m1(l)=1.0_RealK
                p_legendre_ls(l)=cos_sol_view(l, id)
                phase_fnc_solar_cloud(l, i, id)=k_ext_scat_cloud(l, i) &
                  +phase_fnc_cloud(l, i, 1) &
                  *p_legendre_ls(l)*real(2*1+1, RealK)
              ENDDO
              DO ls=2, n_order_phase_solar
!               Calculate higher orders by recurrences. Moments of
!               the phase function cannot be taken from above as
!               we will typically require a much higher order here.
                cnst1=1.0_RealK-1.0_realk/real(ls, realk)
                DO ll=1, n_cloud_profile(i)
                  l=i_cloud_profile(ll, i)
                  p_legendre_tmp(l)=p_legendre_ls(l)
                  p_legendre_ls(l) &
                    =(1.0_RealK+cnst1)*p_legendre_ls(l) &
                    *cos_sol_view(l, id)-cnst1*p_legendre_ls_m1(l)
                  p_legendre_ls_m1(l)=p_legendre_tmp(l)
!
                  SELECT CASE(i_parametrization_ice)
!
                    CASE(IP_slingo_schr_ice_phf)
                      phf_tmp=ice_cloud_parameter(2*ls+3) &
                        +dim_char_ice(l, i) &
                        *ice_cloud_parameter(2*ls+4)
!
                    CASE(IP_ice_fu_phf)
                      x=dim_char_ice(l, i)/ice_cloud_parameter(5*ls+9)
                      phf_tmp &
                        =(ice_cloud_parameter(5*ls+5) &
                        +x*(ice_cloud_parameter(5*ls+6) &
                        +x*(ice_cloud_parameter(5*ls+7) &
                        +x*ice_cloud_parameter(5*ls+8))))
!
                  END SELECT
!
                  ks_phf(l)=k_ext_scat_cloud(l, i)*phf_tmp
                  phase_fnc_solar_cloud(l, i, id) &
                    =phase_fnc_solar_cloud(l, i, id) &
                    +ks_phf(l)*p_legendre_ls(l) &
                    *real(2*ls+1, RealK)
                ENDDO
              ENDDO
            ENDDO
!
!           Continue to an extra order to find the rescaling
!           for the solar beam.
            IF (l_rescale) THEN
              ls=n_order_phase_solar+1
              DO ll=1, n_cloud_profile(i)
                l=i_cloud_profile(ll, i)
!
                SELECT CASE(i_parametrization_ice)
!
                  CASE(IP_slingo_schr_ice_phf)
                    phf_tmp=ice_cloud_parameter(2*ls+3) &
                      +dim_char_ice(l, i) &
                      *ice_cloud_parameter(2*ls+4)
!
                  CASE(IP_ice_fu_phf)
                    x=dim_char_ice(l, i)/ice_cloud_parameter(5*ls+9)
                    phf_tmp &
                      =(ice_cloud_parameter(5*ls+5) &
                      +x*(ice_cloud_parameter(5*ls+6) &
                      +x*(ice_cloud_parameter(5*ls+7) &
                      +x*ice_cloud_parameter(5*ls+8))))
!
                END SELECT
!
                forward_solar_cloud(l, i) &
                  =k_ext_scat_cloud(l, i)*phf_tmp
              ENDDO
            ENDIF
!
          ENDDO
!
        ENDIF
!
      ENDIF
!

!
      IF (i_parametrization_ice == IP_ice_unparametrized) THEN
!
        CALL prsc_opt_prop(ierr &
          , n_profile, n_cloud_top, n_layer &
          , l_rescale, n_order_forward &
          , l_henyey_greenstein_pf, n_order_phase &
          , p, density &
          , n_opt_level_cloud_prsc &
          , ice_pressure_prsc, ice_absorption_prsc, ice_scattering_prsc &
          , ice_phase_fnc_prsc &
          , k_ext_tot_cloud, k_ext_scat_cloud, phase_fnc_cloud &
          , forward_scatter_cloud, forward_solar_cloud &
          , l_solar_phf, n_order_phase_solar, n_direction, cos_sol_view &
          , phase_fnc_solar_cloud &
          , nd_profile, nd_radiance_profile, nd_layer, id_ct, nd_layer &
          , nd_direction &
          , nd_profile_prsc, nd_opt_level_prsc &
          , nd_phase_term, nd_max_order &
          )
!
!       The absorption is returned from prsc_opt_prop in k_ext_tot_cloud.
!       The scattering is added here to give the correct extinction.
        DO i=n_cloud_top, n_layer
          DO ll=1, n_cloud_profile(i)
            l=i_cloud_profile(ll, i)
              k_ext_tot_cloud(l, i) = k_ext_tot_cloud(l, i) &
                + k_ext_scat_cloud(l, i)
          ENDDO
        ENDDO

      ENDIF

!
      IF ( (i_parametrization_ice /= IP_slingo_schrecker_ice).AND. &
           (i_parametrization_ice /= IP_ice_adt).AND. &
           (i_parametrization_ice /= IP_ice_adt_10).AND. &
           (i_parametrization_ice /= IP_sun_shine_vn2_vis).AND. &
           (i_parametrization_ice /= IP_sun_shine_vn2_ir).AND. &
           (i_parametrization_ice /= IP_ice_fu_solar).AND. &
           (i_parametrization_ice /= IP_ice_fu_ir).AND. &
           (i_parametrization_ice /= IP_slingo_schr_ice_phf).AND. &
           (i_parametrization_ice /= IP_ice_fu_phf).AND. &
           (i_parametrization_ice /= IP_ice_unparametrized) ) THEN
!
        WRITE(iu_err, '(/a)') '*** Error: An invalid parametrization ' &
          //'of ice crystals has been used.'
        ierr=i_err_fatal
        RETURN
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE OPT_PROP_ICE_CLOUD
!+ Subroutine to calculate optical properties of water clouds.
!
! Method:
!       If the optical properties come from an observational
!       distribution a separate subroutine is called. Otherwise
!       appropriate mean quantities in the layer are calculated
!       as the parametrization requires and these values are
!       substituted into the parametrization to give the optical
!       properties.
!
!       Note that this routine produces optical propeties for a
!       single condensed component of the cloud.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE opt_prop_water_cloud(ierr &
        , n_profile, n_layer, n_cloud_top &
        , n_cloud_profile, i_cloud_profile &
        , n_order_phase, l_rescale, n_order_forward &
        , l_henyey_greenstein_pf, l_solar_phf, n_order_phase_solar &
        , n_direction, cos_sol_view &
        , i_parametrization_drop, cloud_parameter &
        , liq_water_mass_frac, radius_effect &

        , p, density &
        , n_opt_level_cloud_prsc &
        , drop_pressure_prsc, drop_absorption_prsc &
        , drop_scattering_prsc, drop_phase_fnc_prsc &

        , k_ext_tot_cloud, k_ext_scat_cloud &
        , phase_fnc_cloud, forward_scatter_cloud &
        , forward_solar_cloud, phase_fnc_solar_cloud &
        , nd_profile, nd_radiance_profile, nd_layer, id_ct &
        , nd_direction &
        , nd_phase_term, nd_max_order, nd_cloud_parameter &

        , nd_profile_prsc, nd_opt_level_prsc &

        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE cloud_parametrization_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_radiance_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_direction &
!           Size allocated for viewing directions
        , nd_phase_term &
!           Size allocated for terms in phase function
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_cloud_parameter &
!            Size allocated for cloud parameters

        , nd_profile_prsc &
!           Size allowed for profiles of prescribed optical properties
        , nd_opt_level_prsc
!           Size allowed for levels of prescribed optical properties

!
!     Inclusion of header files.
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Topmost cloudy layer
        , n_order_phase &
!           Number of terms to retain in the phase function
        , n_order_phase_solar &
!           Number of terms to retain in single scattered solar
!           phase function
        , n_order_forward &
!           Order used in forming the forward scattering parameter
        , i_parametrization_drop &
!           Treatment of droplets

        , n_opt_level_cloud_prsc &
!           Number of levels of prescribed optical properties

        , n_cloud_profile(id_ct: nd_layer) &
!           Number of cloudy profiles
        , i_cloud_profile(nd_profile, id_ct: nd_layer)
!           Profiles containing clouds
      LOGICAL, Intent(IN) :: &
          l_rescale &
!           Flag for delta-rescaling
        , l_henyey_greenstein_pf &
!           Flag to use a Henyey-Greenstein phase function
        , l_solar_phf
!           Flag to use an extended solar phase function in
!           single scattering
!
!     Viewing directions:
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing dierctions
      REAL  (RealK), Intent(IN) :: &
          cos_sol_view(nd_radiance_profile, nd_direction)
!           Cosines of the angles between the solar direction
!           and the viewing direction
!
      REAL  (RealK), Intent(IN) :: &
          cloud_parameter(nd_cloud_parameter) &
!           Cloud parameters
        , liq_water_mass_frac(nd_profile, id_ct: nd_layer) &
!           Liquid water content
        , radius_effect(nd_profile, id_ct: nd_layer)
!           Effective radius

      REAL  (RealK), Intent(IN) :: &
          p(nd_profile, nd_layer) &
!           Pressure
        , density(nd_profile, nd_layer) &
!           Atmospheric density
        , drop_pressure_prsc(nd_profile_prsc, nd_opt_level_prsc) &
!           Pressure levels where optical data are prescribed
        , drop_absorption_prsc(nd_profile_prsc, nd_opt_level_prsc) &
!           Prescribed absorption by droplets
        , drop_scattering_prsc(nd_profile_prsc, nd_opt_level_prsc) &
!           Prescribed scattering by droplets
        , drop_phase_fnc_prsc(nd_profile_prsc, nd_opt_level_prsc &
            , nd_phase_term)
!           Prescribed phase function of droplets

      REAL  (RealK), Intent(OUT) :: &
          k_ext_scat_cloud(nd_profile, id_ct: nd_layer) &
!           Scattering extinction
        , k_ext_tot_cloud(nd_profile, id_ct: nd_layer) &
!           Total extinction
        , phase_fnc_cloud(nd_profile, id_ct: nd_layer, nd_max_order) &
!           Cloudy phase function
        , phase_fnc_solar_cloud(nd_radiance_profile, id_ct: nd_layer &
            , nd_direction) &
!           Cloudy phase function for singly scattered solar radiation
        , forward_scatter_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy forward scattering
        , forward_solar_cloud(nd_profile, id_ct: nd_layer)
!           Cloudy forward scattering for the solar beam
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , ll &
!           Loop variable
        , i &
!           Loop variable
        , id &
!           Loop variable
        , ls
!           Loop variable
      REAL  (RealK) :: &
          asymmetry_process(nd_profile, id_ct:nd_layer)
!           Asymmetry of current process.
!
!     Legendre polynomials:
      REAL  (RealK) :: &
          cnst1 &
!           Constant in recurrence for Legendre polynomials
        , p_legendre_ls(nd_radiance_profile) &
!           Legendre polynomial at the current order
        , p_legendre_ls_m1(nd_radiance_profile) &
!           Legendre polynomial at the previous order
        , p_legendre_tmp(nd_radiance_profile) &
!           Temporary Legendre polynomial
        , ks_phf(nd_radiance_profile)
!           Product of the scattering and the current moment of
!           the phase function
!

!     Subroutines called:
!      EXTERNAL &
!          prsc_opt_prop

!
!
!
      IF ( (i_parametrization_drop == IP_slingo_schrecker).OR. &
           (i_parametrization_drop == IP_ackerman_stephens).OR. &
           (i_parametrization_drop == IP_drop_pade_2) ) THEN
!
!       Optical properties are calculated from parametrized data.
!
!hmjb        DO i=n_cloud_top, n_layer
!
!         To avoid the repetition of blocks of code or excessive
!         use of memory it is easiest to have an outer loop over
!         layers.
!
!
        IF (i_parametrization_drop == IP_slingo_schrecker) THEN
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              k_ext_tot_cloud(l, i) &
                =liq_water_mass_frac(l, i)*(cloud_parameter(1) &
                +cloud_parameter(2)/radius_effect(l, i))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0e+00_RealK-cloud_parameter(3) &
                -cloud_parameter(4)*radius_effect(l, i))
              asymmetry_process(l, i)= &
                cloud_parameter(5)+cloud_parameter(6) &
                *radius_effect(l, i)
              phase_fnc_cloud(l, i, 1)= &
                k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        ELSE IF (i_parametrization_drop == IP_ackerman_stephens) THEN
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              k_ext_tot_cloud(l, i)=liq_water_mass_frac(l, i) &
                *(cloud_parameter(1)+cloud_parameter(2) &
                *exp(cloud_parameter(3)*log(radius_effect(l, i))))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0e+00_RealK-cloud_parameter(4) &
                -cloud_parameter(5)*exp(cloud_parameter(6) &
                *log(radius_effect(l, i))))
              asymmetry_process(l, i) &
                =cloud_parameter(7)+cloud_parameter(8) &
                *exp(cloud_parameter(9)*log(radius_effect(l, i)))
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        ELSE IF (i_parametrization_drop == IP_drop_pade_2) THEN
!
!
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              k_ext_tot_cloud(l, i)=liq_water_mass_frac(l, i) &
                *(cloud_parameter(1)+radius_effect(l, i) &
                *(cloud_parameter(2)+radius_effect(l, i) &
                *cloud_parameter(3))) &
                /(1.0e+00_RealK+radius_effect(l, i) &
                *(cloud_parameter(4)+radius_effect(l, i) &
                *(cloud_parameter(5)+radius_effect(l, i) &
                *cloud_parameter(6))))
              k_ext_scat_cloud(l, i)=k_ext_tot_cloud(l, i) &
                *(1.0e+00_RealK &
                -(cloud_parameter(7)+radius_effect(l, i) &
                *(cloud_parameter(8)+radius_effect(l, i) &
                *cloud_parameter(9))) &
                /(1.0e+00_RealK+radius_effect(l, i) &
                *(cloud_parameter(10)+radius_effect(l, i) &
                *cloud_parameter(11))))
              asymmetry_process(l, i) &
                =(cloud_parameter(12)+radius_effect(l, i) &
                *(cloud_parameter(13)+radius_effect(l, i) &
                *cloud_parameter(14))) &
                /(1.0e+00_RealK+radius_effect(l, i) &
                *(cloud_parameter(15)+radius_effect(l, i) &
                *cloud_parameter(16)))
              phase_fnc_cloud(l, i, 1) &
                =k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
            ENDDO
          ENDDO
!
!
        ENDIF
!
!
!         Since these parametrizations include only the asymmetry,
!         it seems reasonable to extend them to higher
!         truncations using the Henyey-Greenstein phase function.
!
        DO ls=2, n_order_phase
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
              phase_fnc_cloud(l, i, ls) &
                =phase_fnc_cloud(l, i, ls-1)*asymmetry_process(l, i)
            ENDDO
          ENDDO
        ENDDO
!
        IF (l_rescale) THEN
!CDIR COLLAPSE
          DO i=id_ct, nd_layer
            DO l=1, nd_profile
                forward_scatter_cloud(l, i) &
                  =k_ext_scat_cloud(l, i) &
                  *asymmetry_process(l, i)**n_order_forward
            ENDDO
          ENDDO
        ENDIF
!
!hmjb == PROBLEM, THIS PART IS NOT FOLLOWING THE NEW CODE ABOVE!
        IF (l_solar_phf) THEN
          DO i=n_cloud_top, n_layer
!           Calculate the solar phase function to higher accuracy.
            DO id=1, n_direction
!             The Legendre polynomials are not stored so as to reduce
!             the requirement for memory at very high orders of solar
!             truncation.
              DO ll=1, n_cloud_profile(i)
                l=i_cloud_profile(ll, i)
!               Initialize the Legendre polynomials at the zeroth and
!               first orders.
                p_legendre_ls_m1(l)=1.0e+00_RealK
                p_legendre_ls(l)=cos_sol_view(l, id)
                ks_phf(l)=k_ext_scat_cloud(l, i)*asymmetry_process(l, i)
                phase_fnc_solar_cloud(l, i, id)=k_ext_scat_cloud(l, i) &
                  +ks_phf(l)*p_legendre_ls(l)*real(2*1+1, RealK)
              ENDDO
              DO ls=2, n_order_phase_solar
!               Calculate higher orders by recurrences.
                cnst1=1.0e+00_RealK-1.0e+00_realk/real(ls, realk)
                DO ll=1, n_cloud_profile(i)
                  l=i_cloud_profile(ll, i)
                  p_legendre_tmp(l)=p_legendre_ls(l)
                  p_legendre_ls(l) &
                    =(1.0e+00_RealK+cnst1)*p_legendre_ls(l) &
                    *cos_sol_view(l, id)-cnst1*p_legendre_ls_m1(l)
                  p_legendre_ls_m1(l)=p_legendre_tmp(l)
                  ks_phf(l)=ks_phf(l)*asymmetry_process(l, i)
                  phase_fnc_solar_cloud(l, i, id) &
                    =phase_fnc_solar_cloud(l, i, id) &
                    +ks_phf(l)*p_legendre_ls(l) &
                    *real(2*ls+1, RealK)
                ENDDO
              ENDDO
!
            ENDDO
!
!           Continue to an extra order to find the rescaling
!           for the solar beam.
            IF (l_rescale) THEN
              DO ll=1, n_cloud_profile(i)
                l=i_cloud_profile(ll, i)
                forward_solar_cloud(l, i) &
                  =ks_phf(l)*asymmetry_process(l, i)
              ENDDO
            ENDIF
!
          ENDDO
        ENDIF
!
      ENDIF
!

!
      IF (i_parametrization_drop == IP_drop_unparametrized) THEN
!
!hmjb == PROBLEM, THIS PART IS NOT FOLLOWING THE NEW CODE ABOVE!
        CALL prsc_opt_prop(ierr &
          , n_profile, n_cloud_top, n_layer &
          , l_rescale, n_order_forward &
          , l_henyey_greenstein_pf, n_order_phase &
          , p, density &
          , n_opt_level_cloud_prsc &
          , drop_pressure_prsc, drop_absorption_prsc &
          , drop_scattering_prsc, drop_phase_fnc_prsc &
          , k_ext_tot_cloud, k_ext_scat_cloud, phase_fnc_cloud &
          , forward_scatter_cloud, forward_solar_cloud &
          , l_solar_phf, n_order_phase_solar, n_direction, cos_sol_view &
          , phase_fnc_solar_cloud &
          , nd_profile, nd_radiance_profile, nd_layer, id_ct, nd_layer &
          , nd_direction &
          , nd_profile_prsc, nd_opt_level_prsc &
          , nd_phase_term, nd_max_order &
          )
!
!       The absorption is returned from prsc_opt_prop in k_ext_tot_cloud.
!       The scattering is added here to give the correct extinction.
        DO i=n_cloud_top, n_layer
          DO ll=1, n_cloud_profile(i)
            l=i_cloud_profile(ll, i)
              k_ext_tot_cloud(l, i) = k_ext_tot_cloud(l, i) &
                + k_ext_scat_cloud(l, i)
          ENDDO
        ENDDO

      ENDIF

!
      IF ( (i_parametrization_drop /= IP_slingo_schrecker).AND. &
           (i_parametrization_drop /= IP_ackerman_stephens).AND. &
           (i_parametrization_drop /= IP_drop_unparametrized).AND. &
           (i_parametrization_drop /= IP_drop_pade_2) ) THEN
        WRITE(iu_err, '(/a)') '*** Error: An invalid parametrization ' &
          //'of cloud droplets has been selected.'
        ierr=i_err_fatal
        RETURN
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE OPT_PROP_WATER_CLOUD
!+ Subroutine to find energy transfer coefficients for coupled overlap.
!
! Method:
!        Energy transfer coefficients for upward and downward radiation
!       at the edges of the layers are calculated assuming maximal
!       overlap of regions of the same nature and random overlap of
!       regions of a different nature.
!
!       Storage and Indexing: Now that solvers for the net flux are no
!       longer supported, the overlap coefficients can be stored more
!       easily. The coefficient referring to downward transfer from the
!       kth to the jth region is stored with a third index of
!       K+N_REGION*(J-1): the coeffieint for upward transfer is stored
!       with an index of N_REGION*(N_REGION+J-1)+K, so that in both
!       cases the originating region changes most frequently with the
!       index.
!
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE overlap_coupled(n_profile, n_layer, n_cloud_top &
        , w_cloud, w_free, n_region, type_region, frac_region, p &
        , i_cloud &
        , cloud_overlap &
        , nd_profile, nd_layer, nd_overlap_coeff, nd_region &
        , id_ct, dp_corr_strat, dp_corr_conv &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE cloud_region_pcf
      USE cloud_scheme_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , nd_overlap_coeff &
!           Maximum number of overlap coefficients
        , nd_region &
!           Maximum number of regions
        , id_ct
!           Topmost declared cloudy layer
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Topmost cloudy layer
        , n_region &
!           Number of cloudy regions
        , type_region(nd_region) &
!           Array holding the type of each region
        , i_cloud
!           Cloud scheme selected
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloud amounts
        , frac_region(nd_profile, id_ct: nd_layer, nd_region) &
!           Fractions of total cloud amount occupied by
!           different regions
        , p(nd_profile, nd_layer) &
!           Pressures at the middles of layers
        , dp_corr_strat &
!           Decorrelation pressure scale for large scale cloud
        , dp_corr_conv
!           Decorrelation pressure scale for convective cloud
!
      REAL  (RealK), Intent(OUT) :: &
          w_free(nd_profile, id_ct: nd_layer) &
!           Cloud-free amounts
        , cloud_overlap(nd_profile, id_ct-1: nd_layer &
            , nd_overlap_coeff)
!           Coefficients for transfer of energy at interface
!
!
!     Local arguments.
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , l &
!           Loop variable
        , k
!           Loop variable
!
!
!     Fixed local values:
      REAL  (RealK) :: &
          dp_corr &
!           Pressure scale over which correlation between cloudy
!           layers is lost
        , corr_factor(nd_profile, nd_region)
!           Correlation factors for each region across the boundary
!           between layers: this represents the fraction of the
!           potentially maximally overlapped region that is actually
!           maximally overlapped.
      REAL  (RealK) :: &
          area_lower(nd_profile, nd_region) &
!           Areas of regions in lower layer
        , area_upper(nd_profile, nd_region) &
!           Areas of regions in lower layer
        , area_overlap(nd_profile, nd_region, nd_region) &
!           Areas of overlap between the different regions:
!           the first index refers to the upper layer
        , area_random_upper(nd_profile, nd_region) &
!           Areas of each region in the upper layer
!           to be overlapped randomly
        , area_random_lower(nd_profile, nd_region) &
!           Areas of each region in the lower layer
!           to be overlapped randomly
        , area_random_tot(nd_profile) &
!           Total randomly overlapped area
        , tol_cloud
!           Tolerance used to detect cloud amounts of 0
!
!
!
      tol_cloud=1.0e+02_RealK*epsilon(tol_cloud)
!
!     Set the free fractions in each layer.
!CDIR COLLAPSE
      DO i=1, nd_layer
        DO l=1, nd_profile
          w_free(l, i)=1.0e+00_RealK-w_cloud(l, i)
        ENDDO
      ENDDO
!
!
!
!     We consider each boundary in turn, comparing the fractions
!     of each region in the layers above and below the boundary.
!
!     Initialize for the layer above the clouds: here the clear
!     region will cover the grid-box.
      DO k=1, n_region
        IF (type_region(k) == IP_region_clear) THEN
          DO l=1, n_profile
            area_upper(l, k)=1.0e+00_RealK
          ENDDO
        ELSE
          DO l=1, n_profile
            area_upper(l, k)=0.0e+00_RealK
          ENDDO
        ENDIF
      ENDDO
!
      DO i=n_cloud_top-1, n_layer
!
!       Set the correlations between like regions at each interface.
!
        IF ( (i_cloud == IP_cloud_triple).OR. &
             (i_cloud == IP_cloud_mix_max) ) THEN
!
!CDIR COLLAPSE
          DO k=1, nd_region
            DO l=1, nd_profile
              corr_factor(l, k)=1.0e+00_RealK
            ENDDO
          ENDDO
!
        ELSE IF (i_cloud == IP_cloud_mix_random) THEN
!
!CDIR COLLAPSE
          DO k=1, nd_region
            DO l=1, nd_profile
              corr_factor(l, k)=0.0e+00_RealK
            ENDDO
          ENDDO
!
        ELSE IF ( (i_cloud == IP_cloud_part_corr).OR. &
                  (i_cloud == IP_cloud_part_corr_cnv) ) THEN
!
          DO k=1, n_region
!
!           Experimental version: set the pressure scales over
!           which decorrelation occurs.
            IF (type_region(k) == IP_region_clear) THEN
              dp_corr=1.0e+00_RealK
            ELSE IF (type_region(k) == IP_region_strat) THEN
              dp_corr=dp_corr_strat
            ELSE IF (type_region(k) == IP_region_conv) THEN
              dp_corr=dp_corr_conv
            ENDIF
!
            IF ( (i < n_layer).AND.(i > 1) ) THEN
              DO l=1, n_profile
                corr_factor(l, k)=exp((p(l, i)-p(l, i+1))/dp_corr)
              ENDDO
            ELSE
!             At the surface and the top of the atmosphere
!             the correlation factor is irrelevant.
              DO l=1, n_profile
                corr_factor(l, k)=1.0e+00_RealK
              ENDDO
            ENDIF
!
          ENDDO
!
        ENDIF
!
!       Set areas of the regions in the lower layer.
        DO k=1, n_region
          IF (i < n_layer) THEN
            IF (type_region(k) == IP_region_clear) THEN
              DO l=1, n_profile
                area_lower(l, k)=w_free(l, i+1)
              ENDDO
            ELSE
              DO l=1, n_profile
                area_lower(l, k)=w_cloud(l, i+1) &
                  *frac_region(l, i+1, k)
              ENDDO
            ENDIF
          ELSE
!           At the very bottom of the column we imagine a notional
!           clear layer below the ground surface.
            IF (type_region(k) == IP_region_clear) THEN
              DO l=1, n_profile
                area_lower(l, k)=1.0e+00_RealK
              ENDDO
            ELSE
              DO l=1, n_profile
                area_lower(l, k)=0.0e+00_RealK
              ENDDO
            ENDIF
          ENDIF
!
!         Begin by setting the maximally overlapped parts of the
!         atmospheric column. The area of common overlap betwen
!         like regions may be incremented by randomly overlapped
!         fractions later.
!
          DO l=1, n_profile
            area_overlap(l, k, k)=corr_factor(l, k) &
              *min(area_lower(l, k), area_upper(l, k))
          ENDDO
!
        ENDDO
!
!       Find the remaining areas of overlap on the assumption that
!       the overlap is random. We initialize the areas of overlap to
!       0 and reset later when such an area is present.
        DO k=1, n_region
          DO j=1, k-1
            DO l=1, n_profile
              area_overlap(l, k, j)=0.0e+00_RealK
              area_overlap(l, j, k)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDDO
!
        DO l=1, n_profile
          area_random_tot(l)=1.0e+00_RealK-area_overlap(l, 1, 1)
        ENDDO
        DO k=2, n_region
          DO l=1, n_profile
            area_random_tot(l)=area_random_tot(l)-area_overlap(l, k, k)
          ENDDO
        ENDDO
!CDIR COLLAPSE
        DO k=1, nd_region
          DO l=1, nd_profile
            area_random_upper(l, k) &
              =area_upper(l, k)-area_overlap(l, k, k)
            area_random_lower(l, k) &
              =area_lower(l, k)-area_overlap(l, k, k)
          ENDDO
        ENDDO
!       To calculate the contributions of random overlap to the
!       areas of overlap we take the randomly overlapped portion
!       of the kth region in the upper layer. The probability that
!       this is overalpped with the randomly overlapped portion of
!       the jth region in the lower layer will be equal to
!       the randomly overlapped area of the lower jth region divided
!       by the total randomly overalpped area. The ratio might become
!       ill-conditioned for small amounts of cloud, the but this
!       should not be an issue as the randomly overalpped area would
!       then be small.
!CDIR COLLAPSE
        DO k=1, nd_region
          DO j=1, nd_region
            DO l=1, nd_profile
              IF (area_random_tot(l) > tol_cloud) THEN
                area_overlap(l, k, j)=area_overlap(l, k, j) &
                  +area_random_upper(l, k) &
                  *area_random_lower(l, j)/area_random_tot(l)
              ENDIF
            ENDDO
          ENDDO
        ENDDO
!
!       Now proceed to find the energy transfer coefficients
!       between the various regions.
!
!       Coefficients for the downward transfer of energy:
!
!       To avoid division by 0 we initialize to default values
!       and reset.
!CDIR COLLAPSE
        DO k=1, nd_region
          DO l=1, nd_profile
            cloud_overlap(l, i, n_region*(k-1)+k)=1.0e+00_RealK
          ENDDO
          DO j=1, k-1
            DO l=1, nd_profile
              cloud_overlap(l, i, n_region*(j-1)+k)=0.0e+00_RealK
              cloud_overlap(l, i, n_region*(k-1)+j)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDDO
!
!CDIR COLLAPSE
        DO k=1, nd_region
          DO l=1, nd_profile
            IF (area_upper(l, k) > tol_cloud) THEN
              DO j=1, nd_region
                cloud_overlap(l, i, n_region*(j-1)+k) &
                  =area_overlap(l, k, j)/area_upper(l, k)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
!
!
!       Coefficients for upward flow of energy:
!
!       To avoid division by 0 we initialize to default values
!       and reset.
        DO k=1, n_region
          DO l=1, n_profile
            cloud_overlap(l, i, n_region*(n_region+k-1)+k) &
              =1.0e+00_RealK
          ENDDO
          DO j=1, k-1
            DO l=1, n_profile
              cloud_overlap(l, i, n_region*(n_region+j-1)+k) &
                =0.0e+00_RealK
              cloud_overlap(l, i, n_region*(n_region+k-1)+j) &
                =0.0e+00_RealK
            ENDDO
          ENDDO
        ENDDO
!
        DO k=1, n_region
          DO l=1, n_profile
            IF (area_lower(l, k) > tol_cloud) THEN
              DO j=1, n_region
                cloud_overlap(l, i, n_region*(n_region+j-1)+k) &
                  =area_overlap(l, j, k)/area_lower(l, k)
              ENDDO
            ENDIF
          ENDDO
        ENDDO
!
!
!       Reassign the fractions in the upper layer to step down
!       through the atmosphere.
        IF (i < n_layer) THEN
          DO k=1, n_region
            DO l=1, n_profile
              area_upper(l, k)=area_lower(l, k)
            ENDDO
          ENDDO
        ENDIF
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE OVERLAP_COUPLED

!+ Subroutine to gather data for spline fitting.
!
! Method:
!     Splined fits to the given data at the corresponding pressure
!     levels are carried out. Optical properties at the required
!     pressure levels are calculated from the splined fits.
!     This routine is not intended to run in vector mode,
!     and has therefore not been optimized for such use.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE prsc_gather_spline(ierr &
        , n_profile, i_first_layer, i_last_layer, p_eval &
        , n_opt_level_prsc, prsc_pressure, prsc_opt_property &
        , opt_property &
        , nd_profile, nd_layer, id_1, id_2 &
        , nd_profile_prsc, nd_opt_level_prsc &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , id_1 &
!           Topmost declared layer
        , id_2 &
!           Bottom declared layer for optical properties
        , nd_profile_prsc &
!           Size allowed for profiles of prescribed properties
        , nd_opt_level_prsc
!           Size allowed for levels of prescribed properties
!
!     Inclusion of header files.
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_first_layer &
!           First layer in which the field is required
        , i_last_layer
!           Last layer in which the field is required
!
      INTEGER, Intent(IN) :: &
          n_opt_level_prsc
!           Number of levels of prescribed optical data
      REAL  (RealK), Intent(IN) :: &
          prsc_pressure(nd_profile_prsc, nd_opt_level_prsc) &
!           Pressures of specified levels
        , prsc_opt_property(nd_profile_prsc, nd_opt_level_prsc) &
!           Prescribed optical properties
        , p_eval(nd_profile, nd_layer)
!           Pressures where the property is to be evaluated
!
      REAL  (RealK), Intent(OUT) :: &
          opt_property(nd_profile, id_1: id_2)
!           Calculated optical property
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i
!           Loop variable
      REAL  (RealK) :: &
          prsc_pressure_g(nd_opt_level_prsc) &
!           Pressures of specified levels
!           gathered to the current profile
        , prsc_opt_property_g(nd_opt_level_prsc) &
!           Prescribed optical property
!           gathered to the current profile
        , d2(nd_opt_level_prsc) &
!           Second derivatives for spline fits
        , work(nd_opt_level_prsc)
!           Working space
!
!     Subroutines called:
!      EXTERNAL &
!          spline_fit, spline_evaluate
!
!
!
!     Calculate the second derivatives for the spline fits.
      DO l=1, n_profile
!
!       Because of checking for data which are out of range the
!       splining routines do not work in vector mode, so points
!       are gathered to a single profile.
!
        DO i=1, n_opt_level_prsc
          prsc_pressure_g(i)=prsc_pressure(l, i)
          prsc_opt_property_g(i)=prsc_opt_property(l, i)
        ENDDO
!
!       Calculate second derivatives for fitting.
        CALL spline_fit(n_opt_level_prsc, prsc_pressure_g &
          , prsc_opt_property_g, d2, work)
!
        DO i=i_first_layer, i_last_layer
!
          CALL spline_evaluate(ierr, n_opt_level_prsc &
            , prsc_pressure_g, prsc_opt_property_g &
            , d2, p_eval(l, i) &
            , opt_property(l, i) &
            )
!         Here, values which are out of range are silently set to 0.
          IF (ierr /= i_normal) THEN
            IF (ierr == i_err_range) THEN
              opt_property(l, i)=0.0e+00_RealK
!             Recover from this error.
              ierr=i_normal
            ELSE
              RETURN
            ENDIF
          ENDIF
!
        ENDDO
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE PRSC_GATHER_SPLINE

!+ Subroutine to set observational optical properties of aerosols.
!
! Method:
!        Splined fits to the given data at the corresponding pressure
!        levels are carried out. Optical properties at the required
!        pressure levels are calculated from the splined fits.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE prsc_opt_prop(ierr &
        , n_profile, i_first_layer, i_last_layer &
        , l_rescale, n_order_forward &
        , l_henyey_greenstein_pf, n_order_phase &
        , p, density &
        , n_opt_level_prsc, prsc_pressure &
        , prsc_absorption, prsc_scattering, prsc_phase_fnc &
        , k_ext_tot, k_ext_scat, phase_fnc &
        , forward_scatter, forward_solar &
        , l_solar_phf, n_order_phase_solar, n_direction, mu_v &
        , phase_fnc_solar &
        , nd_profile, nd_radiance_profile, nd_layer, id_1, id_2 &
        , nd_direction &
        , nd_profile_prsc, nd_opt_level_prsc &
        , nd_phase_term, nd_max_order &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_radiance_profile &
!           Size allocated for points where radiances are calculated
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_1 &
!           Declared topmost layer for optical properties
        , id_2 &
!           Declared bottom layer for optical properties
        , nd_profile_prsc &
!           Size allowed for profiles of prescribed properties
        , nd_opt_level_prsc &
!           Size allowed for levels of prescribed properties
        , nd_phase_term &
!           Size allowed for terms in the phase function
        , nd_max_order &
!           Size allowed orders of spherical harmonics
        , nd_direction
!           Size allowed for viewing directions
!
!     Inclusion of header files.
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_first_layer &
!           First layer where properties are required
        , i_last_layer &
!           Last layer where properties are required
        , n_order_forward &
!           Order used for forward scattering
        , n_order_phase &
!           Number of terms required in the phase function
        , n_order_phase_solar &
!           Number of terms retained in the calculation of the
!           single scattering of solar radiation
        , n_direction
!           Number of viewing directions
      LOGICAL, Intent(IN) :: &
          l_rescale &
!           Flag for rescaling
        , l_henyey_greenstein_pf &
!           Flag to use Henyey-Greenstein phase functions
        , l_solar_phf
!           Flag to calculate the cwsingel scattering of solar
!           radiation directly
      REAL  (RealK), Intent(IN) :: &
          p(nd_profile, nd_layer) &
!           Pressure field
        , density(nd_profile, nd_layer) &
!           Density field
        , mu_v(nd_profile, nd_direction)
!           Viewing directions
!
      INTEGER, Intent(IN) :: &
          n_opt_level_prsc
!           Number of levels of prescribed optical data
      REAL  (RealK), Intent(IN) :: &
          prsc_pressure(nd_opt_level_prsc) &
!           Pressure at prescribed levels
        , prsc_absorption(nd_profile_prsc, nd_opt_level_prsc) &
!           Prescribed absorption
        , prsc_scattering(nd_profile_prsc, nd_opt_level_prsc) &
!           Prescribed scattering
        , prsc_phase_fnc(nd_profile_prsc, nd_opt_level_prsc &
            , nd_phase_term)
!           Prescribed phase function
!
!     Optical properties:
      REAL  (RealK), Intent(OUT) :: &
          k_ext_tot(nd_profile, id_1: id_2) &
!           Extinction
        , k_ext_scat(nd_profile, id_1: id_2) &
!           Scattering
        , phase_fnc(nd_profile, id_1: id_2, nd_max_order) &
!           Phase function: on exit this will be weighted by
!           the scattering.
        , forward_scatter(nd_profile, id_1: id_2) &
!           Forward scattering: on exit this will be weighted by
!           the scattering.
        , forward_solar(nd_profile, id_1: id_2) &
!           Forward scattering for the solar beam: on exit this
!           will be weighted by the scattering.
        , phase_fnc_solar(nd_radiance_profile, id_1: id_2 &
            , nd_direction)
!           Current contribution to the solar phase function:
!           on exit this will be weighted by the scattering.
!
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i &
!           Loop variable
        , id &
!           Loop variable
        , ls &
!           Loop variable
        , n_order_required
!           Order of terms which are required in the phase function
!
!     Legendre polynomials:
      REAL  (RealK) :: &
          cnst1 &
!           Constant in recurrence for Legendre polynomials
        , p_legendre_ls(nd_profile) &
!           Legendre polynomial at the current order
        , p_legendre_ls_m1(nd_profile) &
!           Legendre polynomial at the previous order
        , p_legendre_tmp(nd_profile)
!           Temporary Legendre polynomial
!
!     Temporary variables related to the phase function
      REAL  (RealK) :: &
          asymmetry(nd_profile, id_1: id_2) &
!           Asymmetry
        , phf_coeff(nd_profile, id_1: id_2)
!           Current coefficient in the phase function
!
!
!     Subroutines called:
!      EXTERNAL &
!          prsc_gather_spline
!
!
!
!     Absorption:
!     Put this into the total extinction for now.
      CALL prsc_gather_spline(ierr &
        , n_profile, i_first_layer, i_last_layer, p &
        , n_opt_level_prsc, prsc_pressure, prsc_absorption &
        , k_ext_tot &
        , nd_profile, nd_layer, id_1, id_2 &
        , nd_profile_prsc, nd_opt_level_prsc &
        )
!     Scattering:
      CALL prsc_gather_spline(ierr &
        , n_profile, i_first_layer, i_last_layer, p &
        , n_opt_level_prsc, prsc_pressure, prsc_scattering &
        , k_ext_scat &
        , nd_profile, nd_layer, id_1, id_2 &
        , nd_profile_prsc, nd_opt_level_prsc &
        )
!     Prescribed optical properties are not given as volume extinction
!     coefficients, so they must be scaled by the density.
      DO i=i_first_layer, i_last_layer
        DO l=1, n_profile
          k_ext_scat(l, i)=k_ext_scat(l, i)/density(l, i)
          k_ext_tot(l, i)=k_ext_tot(l, i)/density(l, i)
        ENDDO
      ENDDO
!
!
!     Phase function:
!
      IF (l_henyey_greenstein_pf) THEN
!
!       Interpolate only the first moment of the phase function.
        CALL prsc_gather_spline(ierr &
          , n_profile, i_first_layer, i_last_layer, p &
          , n_opt_level_prsc, prsc_pressure, prsc_phase_fnc(1, 1, 1) &
          , asymmetry &
          , nd_profile, nd_layer, id_1, id_2 &
          , nd_profile_prsc, nd_opt_level_prsc &
          )
!
!       Initialize at the first order including the weighting.
        DO i=i_first_layer, i_last_layer
          DO l=1, n_profile
            phase_fnc(l, i, 1)=k_ext_scat(l, i)*asymmetry(l, i)
          ENDDO
        ENDDO
!
!       Expand all other moments.
        DO ls=2, n_order_phase
          DO i=i_first_layer, i_last_layer
            DO l=1, n_profile
              phase_fnc(l, i, ls) &
                =phase_fnc(l, i, ls-1)*asymmetry(l, i)
            ENDDO
          ENDDO
        ENDDO
!
!       Calculate the forward scattering using special code for
!       the common cases.
        IF (l_rescale) THEN
          IF (n_order_forward == n_order_phase) THEN
            DO i=i_first_layer, i_last_layer
              DO l=1, n_profile
                forward_scatter(l, i)=phase_fnc(l, i, n_order_phase)
              ENDDO
            ENDDO
          ELSE IF (n_order_forward == n_order_phase+1) THEN
            DO i=i_first_layer, i_last_layer
              DO l=1, n_profile
                forward_scatter(l, i)=phase_fnc(l, i, n_order_phase) &
                  *asymmetry(l, i)
              ENDDO
            ENDDO
          ELSE
!           This case is unlikely so inefficient code is used.
            DO i=i_first_layer, i_last_layer
              DO l=1, n_profile
                forward_scatter(l, i)=k_ext_scat(l, i) &
                  *asymmetry(l, i)**n_order_forward
              ENDDO
            ENDDO
          ENDIF
        ENDIF
!
      ELSE
!
        IF (l_rescale) THEN
          n_order_required=max(n_order_phase, n_order_forward)
        ELSE
          n_order_required=n_order_phase
        ENDIF
!
        DO ls=1, n_order_required
!
          CALL prsc_gather_spline(ierr &
            , n_profile, i_first_layer, i_last_layer, p &
            , n_opt_level_prsc, prsc_pressure, prsc_phase_fnc(1, 1, ls) &
            , phase_fnc(1, 1, ls) &
            , nd_profile, nd_layer, id_1, id_2 &
            , nd_profile_prsc, nd_opt_level_prsc &
            )
!
!         The phase function must be weighted by the scattering to
!         calculate the correct overall phase function later.
          DO i=i_first_layer, i_last_layer
            DO l=1, n_profile
              phase_fnc(l, i, ls)=k_ext_scat(l, i)*phase_fnc(l, i, ls)
            ENDDO
          ENDDO
!
        ENDDO
!
!       The forward scattering must also be weighted by the
!       scattering extinction, but this was done within the foregoing
!       loop so here we may simply copy the terms.
        IF (l_rescale) THEN
          DO i=i_first_layer, i_last_layer
            DO l=1, n_profile
              forward_scatter(l, i)=phase_fnc(l, i, n_order_forward)
            ENDDO
          ENDDO
        ENDIF
!
      ENDIF
!
!
!     Higher orders of solar truncation:
      IF (l_solar_phf) THEN
!
!       It is somewhat inefficient to recalculate the lower orders
!       of the phase function, but the coding is simpler and the
!       penalty in practice will not be too great. To avoid using
!       excessive amounts of memory the moments of the phase function
!       are not stored for re-use with different directions.
!       Note that PHF_COEFF is the real coefficient in the phase
!       function, without any weighting by the scattering.
        DO id=1, n_direction
!
!         Calculate the asymmetry at all points and levels
          CALL prsc_gather_spline(ierr &
            , n_profile, i_first_layer, i_last_layer, p &
            , n_opt_level_prsc, prsc_pressure, prsc_phase_fnc(1, 1, 1) &
            , phf_coeff &
            , nd_profile, nd_layer, id_1, id_2 &
            , nd_profile_prsc, nd_opt_level_prsc &
            )
          DO l=1, n_profile
!           Initialize the Legendre polynomials at the zeroth and
!           first orders.
            p_legendre_ls_m1(l)=1.0e+00_RealK
            p_legendre_ls(l)=mu_v(l, id)
          ENDDO
          DO i=i_first_layer, i_last_layer
            DO l=1, n_profile
              phase_fnc_solar(l, i, id)=1.0e+00_RealK+phf_coeff(l, i) &
                *p_legendre_ls(l)*real(2*1+1, RealK)
            ENDDO
          ENDDO
!
          DO ls=2, n_order_phase_solar
!
!           Calculate the current moment of the phase function.
            IF (l_henyey_greenstein_pf) THEN
!             Calculate higher moments using the asymmetry which
!             is available from earlier computations.
              DO i=i_first_layer, i_last_layer
                DO l=1, n_profile
                  phf_coeff(l, i)=phf_coeff(l, i)*asymmetry(l, i)
                ENDDO
              ENDDO
            ELSE
              CALL prsc_gather_spline(ierr &
                , n_profile, i_first_layer, i_last_layer, p &
                , n_opt_level_prsc, prsc_pressure &
                , prsc_phase_fnc(1, 1, ls), phf_coeff &
                , nd_profile, nd_layer, id_1, id_2 &
                , nd_profile_prsc, nd_opt_level_prsc &
                )
            ENDIF
!
!           Calculate higher Legendre polynomials by recurrences.
            cnst1=1.0e+00_RealK-1.0e+00_realk/real(ls, realk)
            DO l=1, n_profile
              p_legendre_tmp(l)=p_legendre_ls(l)
              p_legendre_ls(l) &
                =(1.0e+00_RealK+cnst1)*p_legendre_ls(l)*mu_v(l, id) &
                -cnst1*p_legendre_ls_m1(l)
              p_legendre_ls_m1(l)=p_legendre_tmp(l)
            ENDDO
!
            DO i=i_first_layer, i_last_layer
              DO l=1, n_profile
                phase_fnc_solar(l, i, id)=phase_fnc_solar(l, i, id) &
                  +phf_coeff(l, i)*p_legendre_ls(l) &
                  *real(2*ls+1, RealK)
              ENDDO
            ENDDO
!
          ENDDO
!
!         Weight the phase function with the scattering extinction
!         to perform correct averaging later.
          DO i=i_first_layer, i_last_layer
            DO l=1, n_profile
              phase_fnc_solar(l, i, id)=phase_fnc_solar(l, i, id) &
                *k_ext_scat(l, i)
            ENDDO
          ENDDO
!
          IF (l_rescale) THEN
!           Calculate one extra moment of the phase function to find
!           the forward scattering for theh solar beam.
            IF (l_henyey_greenstein_pf) THEN
!             Calculate higher moments using the asymmetry which
!             is available from earlier computations.
              DO i=i_first_layer, i_last_layer
                DO l=1, n_profile
                  phf_coeff(l, i)=phf_coeff(l, i)*asymmetry(l, i)
                ENDDO
              ENDDO
            ELSE
              ls=n_order_phase_solar+1
              CALL prsc_gather_spline(ierr &
                , n_profile, i_first_layer, i_last_layer, p &
                , n_opt_level_prsc, prsc_pressure &
                , prsc_phase_fnc(1, 1, ls), phf_coeff &
                , nd_profile, nd_layer, id_1, id_2 &
                , nd_profile_prsc, nd_opt_level_prsc &
                )
            ENDIF
!
!           Apply the weighting by the scattering to the forward
!           scattering fraction.
            DO i=i_first_layer, i_last_layer
              DO l=1, n_profile
                forward_solar(l, i) &
                  =k_ext_scat(l, i)*phf_coeff(l, i)
              ENDDO
            ENDDO
!
          ENDIF
!
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE PRSC_OPT_PROP
!+ Subroutine to calculate specific humidities from Gill''s formula.
!
! Method:
!        Straightforward.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE qsat_gill(sat_spec_hum, t, p &
        , n_profile, n_layer &
        , nd_profile, nd_layer &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     This routine computes the saturated specific humidity
!     at temperature T and pressure p, using the formulae given in
!     Appendix four of Adrian Gill''s book.
!
!     Note that the formulae work with pressures in hectopascals and
!     temperatures in degrees celsius. the conversions are made
!     inside this routine and should have no impact on the rest
!     of the code.
!
!     This routine was perpetrated by D L Roberts (12/8/93).
!
!     Modified to cope with very low pressures by DLR (27/10/93).
!
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles.
        , n_layer &
!           Number of layers.
        , nd_profile &
!           Size allocated for atmospheric profiles.
        , nd_layer
!           Size allocated for atmospheric layers.
!
      REAL  (RealK), Intent(IN) :: &
          p(nd_profile, nd_layer) &
!           Pressure in pascals
        , t(nd_profile, nd_layer)
!           Temperature in kelvin
!
      REAL  (RealK), Intent(OUT) :: &
          sat_spec_hum(nd_profile, nd_layer)
!           Saturated specific humidity at T and p.
!
!
!     Local variables.
!
      INTEGER i,l
!
      REAL  (RealK) :: press ! pressure in hectopascals.
      REAL  (RealK) :: temp ! temperature in celsius.
      REAL  (RealK) :: a ! a temporary holding variable.
      REAL  (RealK) :: ew ! saturation vapour pressure of
!                         ! PURE WATER VAPOUR.
      REAL  (RealK) :: ewdash ! sat vap pressure of water vapour in air.
      REAL  (RealK) :: fw ! the ratio between ewdash and ew.
      REAL  (RealK) :: zero_degc ! kelvin equivalent of zero celsius.
!
!     The value assigned is that used in v3.1 of the unified model.
!
      parameter( zero_degc=273.15e+00_RealK )
!
      REAL  (RealK) :: epsilon ! the ratio of the
!                              ! MOLECULAR MASS OF WATER
!                            to that of dry air.
!     The value assigned is that used in v3.1 of the unified model.
!
      parameter( epsilon=0.62198e+00_RealK )
!
      REAL  (RealK) :: eta ! one minus epsilon.
      parameter( eta = 1.0e+00_RealK - epsilon )
!
!
!     Loop over all points.
!     These loops are not indented, in order to make the
!     equations easier to read by keeping them to one line.
!
      DO i = 1,n_layer
      DO l = 1,n_profile
!
!     Convert to local units for temperature and pressure.
!
      temp = t(l,i) - zero_degc
      press = p(l,i)*0.01e+00_RealK
!
!     Equation (A4.7) of Gill''s book.
!
      fw = 1.0e+00_RealK + 1.0e-06_realk*press*( 4.5e+00_realk &
        + 6.0e-04_RealK*temp*temp )
!
!     Equation (A4.5) of Gill.
!
      a = ( 7.859e-01_RealK + 3.477e-02_realk*temp ) &
         /( 1.0e+00_RealK + 4.12e-03_realk*temp )
      ew = 1.0e+01_RealK**a
!
!     Equation (A4.6) of Gill.
!
      ewdash = fw*ew
!
!     The next equation is a rearrangement of Gill''s (A4.3),
!     with w subscripts added because we require saturation.
!
!     Note that at very low pressures a fix has to be applied,
!     to avoid a singularity.
!
      IF (press  >  ewdash) THEN
        sat_spec_hum(l,i) = (epsilon*ewdash)/(press-ewdash*eta)
      ELSE
        sat_spec_hum(l,i) = 1.0e+00_RealK
      ENDIF
!
!     End of the double loop.
!
      ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE QSAT_GILL
!+ Subroutine to apply a path-length scaling to the continuum.
!
! Method:
!        The scaling function is calculated. This is multpiled by a
!        suitable "amount" of continuum incorporating a broadening
!        density.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                first version under RCS
!                                                (J. M. Edwards)
!
! description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE rescale_continuum(n_profile, n_layer, i_continuum &
         , p, t, i_top &
         , density, molar_density_water, molar_density_frn &
         , water_frac &
         , amount_continuum &
         , i_fnc &
         , p_reference, t_reference, scale_parameter &
         , nd_profile, nd_layer &
         , nd_scale_variable &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE physical_constants_0_ccf
      USE continuum_pcf
      USE scale_fnc_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_scale_variable
!           Size allocated for scaling variables
!
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , i_continuum &
!           Continuum type
        , i_fnc &
!           Scaling function
        , i_top
!           Top `index'' of arrays
      REAL  (RealK), Intent(IN) :: &
          water_frac(nd_profile, nd_layer) &
!           Mass fraction of water
        , p(nd_profile, nd_layer) &
!           Pressure
        , t(nd_profile, nd_layer) &
!           Temperature
        , density(nd_profile, nd_layer) &
!           Overall density
        , molar_density_water(nd_profile, nd_layer) &
!           Molar density of water vapour
        , molar_density_frn(nd_profile, nd_layer) &
!           Molar density of foreign species
        , p_reference &
!           Reference pressure
        , t_reference &
!           Reference pressure
        , scale_parameter(nd_scale_variable)
!           Scaling paramters
      REAL  (RealK), Intent(OUT) :: &
          amount_continuum(nd_profile, nd_layer)
!           Amount of continuum
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i
!           Loop variable
!
!
!
      IF (i_fnc == IP_scale_power_law) THEN
        DO i=1, nd_layer
          DO l=1, nd_profile
            amount_continuum(l, i) &
              =exp(scale_parameter(1)*log(p(l, i)/p_reference) &
              +scale_parameter(2)*log(t(l, i)/t_reference))
          ENDDO
        ENDDO
      ELSE if(i_fnc == IP_scale_power_quad) THEN
        DO i=1, nd_layer
          DO l=1, nd_profile
            amount_continuum(l, i) &
              =exp(scale_parameter(1)*log(p(l, i)/p_reference)) &
              *(1.0e+00_RealK+scale_parameter(2)*(t(l, i) &
              /t_reference-1.0e+00_RealK) &
              +scale_parameter(3)*(t(l, i) &
              /t_reference-1.0e+00_RealK)**2)
          ENDDO
        ENDDO
      ENDIF
!
      IF (i_continuum == IP_self_continuum) THEN
        DO i=1, nd_layer
          DO l=1, nd_profile
            amount_continuum(l, i)=amount_continuum(l, i) &
              *molar_density_water(l, i)*water_frac(l, i)
          ENDDO
        ENDDO
      ELSE IF (i_continuum == IP_frn_continuum) THEN
        DO i=1, nd_layer
          DO l=1, nd_profile
            amount_continuum(l, i)=amount_continuum(l, i) &
              *molar_density_frn(l, i)*water_frac(l, i)
          ENDDO
        ENDDO
      ELSE IF (i_continuum == IP_n2_continuum) THEN
        DO i=1, nd_layer
          DO l=1, nd_profile
            amount_continuum(l, i)=amount_continuum(l, i) &
              *n2_mass_frac*density(l, i)
          ENDDO
        ENDDO
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE RESCALE_CONTINUUM
!+ Subroutine to rescale the phase function.
!
! Method:
!        The standard rescaling of the phase function is used.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE rescale_phase_fnc(n_profile &
        , i_layer_first, i_layer_last, n_direction, cos_sol_view &
        , n_order_phase, phase_fnc, forward_scatter, forward_solar &
        , l_rescale_solar_phf, n_order_phase_solar, phase_fnc_solar &
        , nd_profile, nd_radiance_profile, nd_layer, id_1 &
        , nd_direction, nd_max_order &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_radiance_profile &
!           Size allocated for atmospheric profiles used specifically
!           for calculating radiances
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_1 &
!           Topmost declared layer for optical properties
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_direction
!           Size allocated for viewing directions
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to rescale
        , i_layer_last &
!           Last layer to rescale
        , n_direction
!           Number of directions
      LOGICAL, Intent(IN) :: &
          l_rescale_solar_phf
!           Flag to rescale the singly scattered solar phase function
      REAL  (RealK), Intent(IN) :: &
          forward_scatter(nd_profile, id_1: nd_layer) &
!           Forward scattering
        , forward_solar(nd_profile, id_1: nd_layer) &
!           Forward scattering for the solar beam
        , cos_sol_view(nd_radiance_profile, nd_direction)
!           Cosines of the angles between the solar direction
!           and the viewing directions
      INTEGER, Intent(IN) :: &
          n_order_phase &
!           Order of terms in the phase function to be retained
        , n_order_phase_solar
!           Order of terms retained in treating singly scattered
!           solar radiation
      REAL  (RealK), Intent(INOUT) :: &
          phase_fnc(nd_profile, id_1: nd_layer, nd_max_order) &
!           Phase function
        , phase_fnc_solar(nd_radiance_profile, id_1: nd_layer &
            , nd_direction)
!           The phase function for single scattered solar radiation
!
!     Local variables
      INTEGER &
          i &
!           Loop variable
        , k &
!           Loop variable
        , l &
!           Loop variable
        , id &
!           Loop variable
        , ls
!           Loop variable
!
!     Legendre polynomials:
      REAL  (RealK) :: &
          cnst1 &
!           Constant in recurrence for Legendre polynomials
        , p_legendre_ls(nd_radiance_profile) &
!           Legendre polynomial at the current order
        , p_legendre_ls_m1(nd_radiance_profile) &
!           Legendre polynomial at the previous order
        , p_legendre_tmp(nd_radiance_profile)
!           Temporary Legendre polynomial
!
      REAL  (RealK) :: &
          peak(nd_profile)
!           Forward scattering peak
!
!
!
!CDIR COLLAPSE
      DO k=1, n_order_phase
        DO i=id_1, nd_layer
          DO l=1, nd_profile
            phase_fnc(l, i, k) &
              =(phase_fnc(l, i, k)-forward_scatter(l, i)) &
              /(1.0e+00_RealK-forward_scatter(l, i))
          ENDDO
        ENDDO
      ENDDO
!
!
      IF (l_rescale_solar_phf) THEN
!
        DO id=1, n_direction
!
!         As usual we do not store Legendre polynomials:
          DO l=1, n_profile
            p_legendre_ls_m1(l)=1.0e+00_RealK
            p_legendre_ls(l)=cos_sol_view(l, id)
            peak(l)=1.0e+00_RealK+p_legendre_ls(l)*real(2*1+1, realk)
          ENDDO
!
          DO ls=2, n_order_phase_solar
!           Calculate higher orders by recurrences.
            cnst1=1.0e+00_RealK-1.0e+00_realk/real(ls, realk)
            DO l=1, n_profile
              p_legendre_tmp(l)=p_legendre_ls(l)
              p_legendre_ls(l) &
                =(1.0e+00_RealK+cnst1)*p_legendre_ls(l) &
                *cos_sol_view(l, id)-cnst1*p_legendre_ls_m1(l)
              p_legendre_ls_m1(l)=p_legendre_tmp(l)
              peak(l)=peak(l)+real(2*ls+1, RealK)*p_legendre_ls(l)
            ENDDO
          ENDDO
!
!         This is not precisely a rescaling because we do not conserve
!         the forward peak, but what is calculated is what contributes
!         to scattered radiation outside the aureole.
!CDIR COLLAPSE
          DO i=id_1, nd_layer
            DO l=1, nd_profile
              phase_fnc_solar(l, i, id)=(phase_fnc_solar(l, i, id) &
                -forward_solar(l, i)*peak(l)) &
                /(1.0e+00_RealK-forward_scatter(l, i))
            ENDDO
          ENDDO
!
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE RESCALE_PHASE_FNC
!+ Subroutine to rescale optical depth and albedo.
!
! Method:
!        The standard rescaling formulae are applied.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE rescale_tau_omega(n_profile &
        , i_layer_first, i_layer_last &
        , tau, omega, forward_scatter &
        , nd_profile, nd_layer, id_1 &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , id_1
!           Topmost declared layer for optical properties
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to rescale
        , i_layer_last
!           First layer to rescale
      REAL  (RealK), Intent(IN) :: &
          forward_scatter(nd_profile, id_1: nd_layer)
!           Forward scattering
      REAL  (RealK), Intent(INOUT) :: &
          tau(nd_profile, id_1: nd_layer) &
!           Optical depth
        , omega(nd_profile, id_1: nd_layer)
!           Albedo of single scattering
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!
!
      DO i=id_1, nd_layer
        DO l=1, nd_profile
          tau(l, i)=tau(l, i)*(1.0e+00_RealK &
            -omega(l, i)*forward_scatter(l, i))
          omega(l, i)=omega(l, i)*(1.0e+00_RealK-forward_scatter(l, i)) &
            /(1.0e+00_RealK-omega(l, i)*forward_scatter(l, i))
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE RESCALE_TAU_OMEGA
!+ Subroutine to scale amounts of absorbers.
!
! Method:
!        The mixing ratio is multiplied by a factor determined
!        by the type of scaling selected.
!
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE scale_absorb(ierr, n_profile, n_layer &
        , gas_mix_ratio, p, t, i_top &
        , gas_frac_rescaled &
        , i_fnc, p_reference, t_reference, scale_parameter &
        , l_doppler, doppler_correction &
        , nd_profile, nd_layer &
        , nd_scale_variable &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE scale_fnc_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , nd_scale_variable
!           Size allocated for of scaling variables
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , i_fnc &
!           Type of scaling function
        , i_top
!           Uppermost `index'' for scaling (this will be 1 for fields
!           Given in layers, as in the unified model, or 0 for
!           Fields given at the boundaries of layers)
      LOGICAL, Intent(IN) :: &
          l_doppler
!           Flag for Doppler term
      REAL  (RealK), Intent(IN) :: &
          gas_mix_ratio(nd_profile, nd_layer) &
!           Mass mixing ratio of gas
        , p(nd_profile, nd_layer) &
!           Pressure
        , t(nd_profile, nd_layer) &
!           Temperature
        , p_reference &
!           Reference pressure
        , t_reference &
!           Reference temperature
        , scale_parameter(nd_scale_variable) &
!           Scaling paramters
        , doppler_correction
!           Doppler-broadening correction
      REAL  (RealK), Intent(OUT) :: &
          gas_frac_rescaled(nd_profile, nd_layer)
!           Mass fraction of gas
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i
!           Loop variable
      REAL  (RealK) :: &
          pressure_offset
!           Offset to pressure
!
!
!
!     Set the offset to the pressure for the Doppler correction.
      IF (l_doppler) THEN
        pressure_offset=doppler_correction
      ELSE
        pressure_offset=0.0e+00_RealK
      ENDIF
!
!     The array gas_frac_rescaled is used initially to hold only the
!     scaling functions, and only later is it multiplied by the
!     mixing ratios
!
      IF (i_fnc == IP_scale_power_law) THEN
        DO i=1, nd_layer
          DO l=1, nd_profile
            gas_frac_rescaled(l, i)= &
              exp(scale_parameter(1)*log((p(l, i) &
              +pressure_offset) &
              /(p_reference+pressure_offset)) &
              +scale_parameter(2)*log(t(l, i)/t_reference))
          ENDDO
        ENDDO
      ELSE IF (i_fnc == IP_scale_fnc_null) THEN
        RETURN
      ELSE IF (i_fnc == IP_scale_power_quad) THEN
        DO i=1, nd_layer
          DO l=1, nd_profile
            gas_frac_rescaled(l, i)= &
              exp(scale_parameter(1) &
              *log((p(l, i)+pressure_offset) &
              /(p_reference+pressure_offset))) &
              *(1.0e+00_RealK &
              +scale_parameter(2)*(t(l, i)/t_reference-1.0e+00_RealK) &
              +scale_parameter(3)*(t(l, i) &
              /t_reference-1.0e+00_RealK)**2)
          ENDDO
        ENDDO
      ELSE IF (i_fnc == IP_scale_doppler_quad) THEN
!       There is no Doppler term here since it is implicitly included
!       in the scaling.
        DO i=1, nd_layer
          DO l=1, nd_profile
            gas_frac_rescaled(l, i)= &
              exp(scale_parameter(1) &
              *log((p(l, i)+scale_parameter(2)) &
              /(p_reference+scale_parameter(2)))) &
              *(1.0e+00_RealK &
              +scale_parameter(3)*(t(l, i)/t_reference-1.0e+00_RealK) &
              +scale_parameter(4)*(t(l, i) &
              /t_reference-1.0e+00_RealK)**2)
          ENDDO
        ENDDO
      ELSE
        WRITE(iu_err, '(/a)') &
          '*** Error: An illegal type of scaling has been given.'
        ierr=i_err_fatal
        RETURN
      ENDIF
!
!     Multiply by the mixing ratio and limit negative scalings.
      DO i=1, nd_layer
        DO l=1, nd_profile
          gas_frac_rescaled(l, i)=max(0.0e+00_RealK &
            , gas_frac_rescaled(l, i)*gas_mix_ratio(l, i))
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SCALE_ABSORB
!+ Subroutine to set geometry of clouds.
!
! Method:
!        For use in multi-column mode arrays are set for each layer
!        pointing to profiles which have non-negligible clear or
!        cloudy fractions. The topmost cloudy layers are also
!        detected.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE set_cloud_geometry(n_profile, n_layer &
        , l_global_cloud_top, n_cloud_top_global, w_cloud &
        , n_cloud_top, n_cloud_profile, i_cloud_profile &
        , nd_profile, nd_layer, id_ct &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , id_ct
!           Topmost declared cloudy layer
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric profiles
        , n_layer
!           Number of layers
!
      LOGICAL, Intent(IN) :: &
          l_global_cloud_top
!           Flag to use a global value for the topmost cloudy layer
      INTEGER, Intent(IN) :: &
          n_cloud_top_global
!           Global topmost cloudy layer
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer)
!           Amounts of cloud
!
      INTEGER, Intent(OUT) :: &
          n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_profile(id_ct: nd_layer) &
!           Number of cloudy profiles
        , i_cloud_profile(nd_profile, id_ct: nd_layer)
!           Profiles containing clouds
!
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i
!           Loop variable
!
!
!
      DO i=id_ct, n_layer
        n_cloud_profile(i)=0
        DO l=1, n_profile
          IF (w_cloud(l, i) > 0.0e+00_RealK) THEN
            n_cloud_profile(i)=n_cloud_profile(i)+1
            i_cloud_profile(n_cloud_profile(i), i)=l
          ENDIF
        ENDDO
      ENDDO
!
      IF (l_global_cloud_top) THEN
        n_cloud_top=n_cloud_top_global
      ELSE
        n_cloud_top=id_ct
        DO while ( (n_cloud_top < n_layer).AND. &
                   (n_cloud_profile(n_cloud_top) == 0) )
          n_cloud_top=n_cloud_top+1
        ENDDO
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE SET_CLOUD_GEOMETRY
!+ Subroutine to set pointers to types of clouds
!
! Method:
!        The types of condensate included are examined. Their phases
!        are set and depending on the representation of clouds adopted
!        it is determined to which type of cloud they contribute.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   Fortran 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE set_cloud_pointer(ierr &
         , n_condensed, type_condensed, i_cloud_representation &
         , l_drop, l_ice &
         , i_phase_cmp, i_cloud_type, l_cloud_cmp &
         , nd_cloud_component &
         )
!
!
!
      USE def_std_io_icf
      USE error_pcf
      USE cloud_component_pcf
      USE cloud_representation_pcf
      USE cloud_type_pcf
      USE phase_pcf
!
!
!
      IMPLICIT NONE
!
!
!     Dimensions of arrays
      INTEGER, Intent(IN) :: &
        nd_cloud_component
!         Maximum number of condensed components allowed in clouds
!
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_condensed &
!           Number of condensed components
        , type_condensed(nd_cloud_component) &
!           Types of components
        , i_cloud_representation
!           Representation of clouds used
      LOGICAL, Intent(IN) :: &
          l_drop &
!           Flag for inclusion of droplets
        , l_ice
!           Flag for inclusion of ice crystals
!
      INTEGER, Intent(OUT) :: &
          i_phase_cmp(nd_cloud_component) &
!           Phases of components
        , i_cloud_type(nd_cloud_component)
!           Types of cloud to which each component contributes
      LOGICAL, Intent(OUT) :: &
          l_cloud_cmp(nd_cloud_component)
!           Logical switches to `include'' components
!
!
!     Local variables
      INTEGER &
          k
!           Loop variable
!
!
!
      DO k=1, n_condensed
!
        i_cloud_type(k)=0
!       Set pointers for valid condensed components.
        IF (i_cloud_representation == IP_cloud_homogen) THEN
!
          IF (type_condensed(k) == IP_clcmp_st_water) THEN
            i_cloud_type(k)=IP_cloud_type_homogen
          ELSEIF (type_condensed(k) == IP_clcmp_st_ice) THEN
            i_cloud_type(k)=IP_cloud_type_homogen
          ENDIF
!
        ELSE IF (i_cloud_representation == IP_cloud_ice_water) THEN
!
          IF (type_condensed(k) == IP_clcmp_st_water) THEN
            i_cloud_type(k)=IP_cloud_type_water
          ELSEIF (type_condensed(k) == IP_clcmp_st_ice) THEN
            i_cloud_type(k)=IP_cloud_type_ice
          ENDIF
!
        ELSE IF (i_cloud_representation == IP_cloud_conv_strat) THEN
!
          IF (type_condensed(k) == IP_clcmp_st_water) THEN
            i_cloud_type(k)=IP_cloud_type_strat
          ELSE IF (type_condensed(k) == IP_clcmp_st_ice) THEN
            i_cloud_type(k)=IP_cloud_type_strat
          ELSEIF (type_condensed(k) == IP_clcmp_cnv_water) THEN
            i_cloud_type(k)=IP_cloud_type_conv
          ELSE IF (type_condensed(k) == IP_clcmp_cnv_ice) THEN
            i_cloud_type(k)=IP_cloud_type_conv
          ENDIF
!
        ELSE IF (i_cloud_representation == IP_cloud_csiw) THEN
!
          IF (type_condensed(k) == IP_clcmp_st_water) THEN
            i_cloud_type(k)=IP_cloud_type_sw
          ELSEIF (type_condensed(k) == IP_clcmp_st_ice) THEN
            i_cloud_type(k)=IP_cloud_type_si
          ELSEIF (type_condensed(k) == IP_clcmp_cnv_water) THEN
            i_cloud_type(k)=IP_cloud_type_cw
          ELSEIF (type_condensed(k) == IP_clcmp_cnv_ice) THEN
            i_cloud_type(k)=IP_cloud_type_ci
          ENDIF
!
        ENDIF
!
!       Check for 0 flagging illegal types.
        IF (i_cloud_type(k) == 0) THEN
          WRITE(iu_err, '(/a)') &
            '*** Error: A component is not compatible with the ' &
            //'representation of clouds selected.'
          ierr=i_err_fatal
          RETURN
        ENDIF
!
        IF (type_condensed(k) == IP_clcmp_st_water) THEN
!
          i_phase_cmp(k)=IP_phase_water
          l_cloud_cmp(k)=l_drop
!
        ELSE IF (type_condensed(k) == IP_clcmp_st_ice) THEN
!
          i_phase_cmp(k)=IP_phase_ice
          l_cloud_cmp(k)=l_ice
!
        ELSE IF (type_condensed(k) == IP_clcmp_cnv_water) THEN
!
          i_phase_cmp(k)=IP_phase_water
          l_cloud_cmp(k)=l_drop
!
        ELSE IF (type_condensed(k) == IP_clcmp_cnv_ice) THEN
!
          i_phase_cmp(k)=IP_phase_ice
          l_cloud_cmp(k)=l_ice
!
        ENDIF
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SET_CLOUD_POINTER
!+ Subroutine to set weights for the C.F. along a direction.
!
! Purpose:
!   The complementary function for the radiation involves unknown
!   coefficients: we set the weights for these coefficients in the
!   current layer here.
!
! Method:
!   Straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE set_dirn_weights(n_profile &
        , ms, ls_trunc, up_lm &
        , n_direction, mu_v, azim_factor &
        , n_viewing_level, i_rad_layer, frac_rad_layer, i &
        , n_red_eigensystem, mu, eig_vec &
        , isolir, z_sol, mu_0 &
        , l_ir_source_quad, diff_planck &
        , upm_c, k_sol &
        , tau, omega, phase_fnc &
        , weight_u, radiance &
        , nd_profile, nd_layer, nd_direction, nd_viewing_level &
        , nd_red_eigensystem, nd_max_order &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!
!     Dummy arguments:
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_direction &
!           Size allocated for viewing directions
        , nd_red_eigensystem &
!           Size allocated for the reduced eigensystem
        , nd_max_order
!           Size allocated for orders of spherical harmonics
!
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric profiles
        , n_direction &
!           Number of directions
        , n_viewing_level &
!           Number of levels where the radiance is calculated
        , i_rad_layer(nd_viewing_level) &
!           Indices of layers containing viewing levels
        , n_red_eigensystem
!           Size of the reduced eigensystem
      INTEGER, Intent(IN) :: &
          i &
!           Current layer
        , ms &
!           Current azimuthal order
        , ls_trunc &
!           Order of polar truncation
        , isolir
!           Index of spectral region
!
      REAL  (RealK), Intent(IN) :: &
          mu_v(nd_profile, nd_direction) &
!           Cosines of polar viewing angles
        , azim_factor(nd_profile, nd_direction) &
!           Azimuthal factors
        , frac_rad_layer(nd_viewing_level) &
!           Fraction optical depth into its layer of the
!           viewing level
        , mu_0(nd_profile) &
!           Cosines of solar zenith angle
        , tau(nd_profile, nd_layer) &
!           Optical depths
        , omega(nd_profile, nd_layer) &
!           Albedos of single scattering
        , phase_fnc(nd_profile, nd_layer, nd_max_order) &
!           Phase function
        , mu(nd_profile, nd_red_eigensystem) &
!           Eigenvalues of the reduced eigensystem
        , eig_vec(nd_profile, 2*nd_red_eigensystem &
            , nd_red_eigensystem) &
!           Eigenvalues of the full eigensystem scaled by
!           the s-parameters
        , z_sol(nd_profile, ls_trunc+1-ms)
!           Coefficient of the solar source function
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic IR-sources
      REAL  (RealK), Intent(IN) :: &
          diff_planck(nd_profile, nd_layer)
!           Differences in the hemispheric Planckian FLUX (bottom-top)
!           across the layer
      INTEGER, Intent(IN) :: &
          k_sol(nd_profile)
!           Indices of eigenvalues used to restore solar conditioning
      REAL  (RealK), Intent(IN) :: &
          upm_c(nd_profile, 2*nd_red_eigensystem)
!           Coefficients of homogeneous solution used to restore
!           conditioning
!
      REAL  (RealK), Intent(INOUT) :: &
          radiance(nd_profile, nd_viewing_level, nd_direction)
!           Radiances (to be incremented by the contribution of
!           the particular integral)
      REAL  (RealK), Intent(OUT) :: &
          weight_u(nd_profile, nd_viewing_level &
            , nd_direction, 2*nd_red_eigensystem)
!           Weights for the coefficients in the complementary
!           function
!
!
!     Local variables
      INTEGER &
          l &
!           Loop variable (points)
        , ir &
!           Loop variable (radiative levels)
        , id &
!           Loop variable (directions)
        , ls &
!           Loop variable (polar orders)
        , ll &
!           Loop variable
        , k &
!           Loop variable
        , ii
!           Loop variable
      INTEGER &
          n_list_up &
!           Numbers of points where the current viewing direction
!           points up
        , list_up(nd_profile) &
!           List up points with where the current viewing direction
!           points up
        , n_list_down &
!           Numbers of points where the current viewing direction
!           points down
        , list_down(nd_profile)
!           List up points with where the current viewing direction
!           points up
      REAL  (RealK) :: &
          geom_solar(nd_profile) &
!           Geometrical factor for solar radiation
        , geom_integ_m(nd_profile) &
!           Geometrical factor for negative eigenvalues
        , geom_integ_p(nd_profile) &
!           Geometrical factor for positive eigenvalues
        , m_slant_depth_near(nd_profile) &
!           Minus slantwise optical distance between the radiance
!           level and the nearer boundary of the current layer
        , m_slant_depth_inc(nd_profile) &
!           Minus the increment in the slantwise optical distance
!           between the boundaries of the current layer or partial
!           layer when the viewing level lies within it
        , up_lm(nd_profile, nd_max_order+1, nd_direction) &
!           Spherical harmonics at a fixed azimuthal order
        , ls_sum_s(nd_profile) &
!           Sum of terms over polar orders in the solar integral
        , ls_sum_p(nd_profile, nd_red_eigensystem) &
!           Sum of terms over polar orders in the integral over
!           eigenvalues
        , ls_sum_m(nd_profile, nd_red_eigensystem) &
!           Sum of terms over polar orders in the integral over
!           eigenvalues
        , tau_i(nd_profile) &
!           Optical depth of the relevant part of the current layer
        , frac_tau_i(nd_profile) &
!           Fractional of the optical depth of the current layer in
!           the relevant part
        , trans_top(nd_profile) &
!           Solar transmission from the top of the current layer to the
!           viewing level within the current layer
        , d_mu &
!           Difference in cosines of directions
        , x &
!           Temporary variable
        , m1lsms
!           -1^(l+m)
!
!     Variables related to the treatment of ill-conditioning
      REAL  (RealK) :: &
          eps_r &
!           The smallest real number such that 1.0-EPS_R is not 1
!           to the computer''s precision
        , sq_eps_r &
!           The square root of the above
        , eta &
!           The conditioning weight
        , eta_nm
!           The conditioning multiplier applied in the numerator
!
!     Subroutines called
!      EXTERNAL &
!          eval_uplm
!
!
!
!     Set the tolerances used in avoiding ill-conditioning, testing
!     on any variable.
      eps_r=epsilon(mu_0(1))
      sq_eps_r=sqrt(eps_r)
!     Consider each level where radiances are required in turn
!     and calculate appropriate weightings. The expressions for
!     these weightings will look slightly different if the radiance
!     level lies within the current layer.
      DO id=1, n_direction
!
!       Assemble the list of points where the direction is upward
!       or downard. Viewing along a horizontal direction is not
!       considered valid (and should be filtered out before this).
        n_list_up=0
        n_list_down=0
        DO l=1, n_profile
          IF (mu_v(l, id) > 0.0e+00_RealK) THEN
            n_list_up=n_list_up+1
            list_up(n_list_up)=l
          ELSE IF (mu_v(l, id) < 0.0e+00_RealK) THEN
            n_list_down=n_list_down+1
            list_down(n_list_down)=l
          ENDIF
        ENDDO
!
!       Sum the terms which vary with the polar order, but
!       are independent of the viewing level.
!       First the contributions to the particular integral:
        IF (isolir == IP_solar) THEN
!
          IF (ms == 0) THEN
!           The zeroth moment of the phase function is not stored
!           because it is 1, but this means that we need some
!           special code to treat the exception.
            DO l=1, n_profile
              ls_sum_s(l)=up_lm(l, 1, id)*z_sol(l, 1)
            ENDDO
          ELSE
            DO l=1, n_profile
              ls_sum_s(l)=phase_fnc(l, i, ms)*up_lm(l, 1, id) &
                *z_sol(l, 1)
            ENDDO
          ENDIF
          DO ls=ms+1, ls_trunc
            DO l=1, n_profile
              ls_sum_s(l)=ls_sum_s(l)+z_sol(l, ls+1-ms) &
                *phase_fnc(l, i, ls)*up_lm(l, ls+1-ms, id)
            ENDDO
          ENDDO
!
        ENDIF
!
!
        DO k=1, n_red_eigensystem
          IF (ms == 0) THEN
            DO l=1, n_profile
              ls_sum_p(l, k)=up_lm(l, 1, id)*eig_vec(l, 1, k)
              ls_sum_m(l, k)=ls_sum_p(l, k)
            ENDDO
          ELSE
            DO l=1, n_profile
              ls_sum_p(l, k)=phase_fnc(l, i, ms)*up_lm(l, 1, id) &
                *eig_vec(l, 1, k)
              ls_sum_m(l, k)=ls_sum_p(l, k)
            ENDDO
          ENDIF
          DO ls=ms+1, ls_trunc
            m1lsms=real(1-2*mod((ls+ms), 2), RealK)
            DO l=1, n_profile
              x=phase_fnc(l, i, ls)*up_lm(l, ls+1-ms, id) &
                *eig_vec(l, ls+1-ms, k)
              ls_sum_p(l, k)=ls_sum_p(l, k)+x
              ls_sum_m(l, k)=ls_sum_m(l, k)+x*m1lsms
            ENDDO
          ENDDO
        ENDDO
!
!
        DO ir=1, n_viewing_level
!
!         Initialize the weights:
          DO k=1, 2*n_red_eigensystem
            DO l=1, n_profile
              weight_u(l, ir, id, k)=0.0e+00_RealK
            ENDDO
          ENDDO
!
!         Upward radiation:
!         No layers above the viewing level contribute here.
!
          IF (i >= i_rad_layer(ir)) THEN
!
!           Calculate minus the slantwise optical depths to the
!           boundaries of the layer. If the level where the radiance
!           is required lies in the current layer we perform the
!           calculation for a temporary layer reaching from the
!           viewing level to the bottom of the current layer.
            IF (i > i_rad_layer(ir)) THEN
!             Full layers are required.
              DO ll=1, n_list_up
                l=list_up(ll)
                m_slant_depth_near(l) &
                  =(1.0e+00_RealK-frac_rad_layer(ir)) &
                  *tau(l, i_rad_layer(ir))
              ENDDO
              DO ii=i_rad_layer(ir)+1, i-1
                DO ll=1, n_list_up
                  l=list_up(ll)
                  m_slant_depth_near(l) &
                    =m_slant_depth_near(l)+tau(l, ii)
                ENDDO
              ENDDO
              DO ll=1, n_list_up
                l=list_up(ll)
                m_slant_depth_near(l) &
                  =-m_slant_depth_near(l)/mu_v(l, id)
                m_slant_depth_inc(l)=-tau(l, i)/mu_v(l, id)
                tau_i(l)=tau(l, i)
                frac_tau_i(l)=1.0e+00_RealK
              ENDDO
              IF (isolir == IP_solar) THEN
                DO ll=1, n_list_up
                  l=list_up(ll)
                  trans_top(l)=1.0e+00_RealK
                ENDDO
              ENDIF
            ELSE IF (i == i_rad_layer(ir)) THEN
!             The viewing level lies in the current layer.
              DO ll=1, n_list_up
                l=list_up(ll)
                m_slant_depth_near(l)=0.0e+00_RealK
                frac_tau_i(l)=1.0e+00_RealK-frac_rad_layer(ir)
                tau_i(l)=frac_tau_i(l)*tau(l, i)
                m_slant_depth_inc(l)=-tau_i(l)/mu_v(l, id)
              ENDDO
              IF (isolir == IP_solar) THEN
                DO ll=1, n_list_up
                  l=list_up(ll)
                  trans_top(l) &
                    =exp(-frac_rad_layer(ir)*tau(l, i)/mu_0(l))
                ENDDO
              ENDIF
            ENDIF
!
!
            IF (isolir == IP_solar) THEN
!             Set the geometrical terms for the solar integral.
              DO ll=1, n_list_up
                l=list_up(ll)
                geom_solar(l)=(mu_0(l)/(mu_0(l)+mu_v(l, id))) &
                  *exp(m_slant_depth_near(l))*(1.0e+00_RealK &
                  -exp(m_slant_depth_inc(l)-tau_i(l)/mu_0(l)))
              ENDDO
!             Add the contribution of the particular integral to the
!             radiance. TRANS_TOP is required to adjust the solar
!             particular integral from its value at the top of the
!             actual layer to its value at the top of the notional
!             layer when the viewing level lies within the current
!             layer.
              DO ll=1, n_list_up
                l=list_up(ll)
                radiance(l, ir, id) &
                  =radiance(l, ir, id)+azim_factor(l, id) &
                  *ls_sum_s(l)*omega(l, i)*geom_solar(l)*trans_top(l)
              ENDDO
            ELSE IF (isolir == IP_infra_red) THEN
              IF (ms == 0) THEN
                IF (l_ir_source_quad) THEN
                  print*, 'not done'
                ELSE
                  DO ll=1, n_list_up
                    l=list_up(ll)
!                   The azimuthal factor is omitted since it will be 1.
!                   Numerical ill-conditioning can arise when the
!                   optical depth is small, necessitating special
!                   treatment.
                    IF (m_slant_depth_inc(l) < -sq_eps_r) THEN
                      x=exp(m_slant_depth_near(l)) &
                      *(1.0e+00_RealK-exp(m_slant_depth_inc(l))) &
                      /m_slant_depth_inc(l)
                    ELSE
!                     Keep the first couple of terms from a power
!                     series.
                      x=-exp(m_slant_depth_near(l))*(1.0e+00_RealK &
                        +0.5e+00_RealK*m_slant_depth_inc(l))
                    ENDIF
                    radiance(l, ir, id) &
                      =radiance(l, ir, id) &
                      -(diff_planck(l, i)/pi)*x*frac_tau_i(l) &
                      /(1.0_RealK-omega(l, i)*phase_fnc(l, i, 1))
                  ENDDO
                ENDIF
              ENDIF
            ENDIF
!
!           Determine the contribution from each eigenvalue.
            DO k=1, n_red_eigensystem
              DO ll=1, n_list_up
                l=list_up(ll)
!               The term for u^+:
!               This may exhibit ill-conditioning, so it is perturbed
!               using L''Hopital's rule (actually we keep two terms in
!               the expansion).
                d_mu=mu(l, k)-mu_v(l, id)
                eta=eps_r/(d_mu+sign(sq_eps_r, d_mu))
                x=tau_i(l)/(mu(l, k)*mu_v(l, id))
                eta_nm=1.0_RealK-eta*x*(1.0_realk+0.5*realk*x*d_mu)
                geom_integ_p(l) &
                  =(mu(l, k)/(d_mu+eta))*exp(m_slant_depth_near(l)) &
                  *(exp(-tau_i(l)/mu(l, k))*eta_nm &
                  -exp(m_slant_depth_inc(l)))
                geom_integ_m(l) &
                  =(mu(l, k)/(mu(l, k)+mu_v(l, id))) &
                  *exp(m_slant_depth_near(l)) &
                  *(exp(-(tau(l, i)-tau_i(l))/mu(l, k)) &
                  -exp(m_slant_depth_inc(l)-tau(l, i)/mu(l, k)))
              ENDDO
!
!             Combine to form the weights for each element of the
!             solution. Only a poprtion of WEIGHT_U is passed to this
!             routine, so the offsetting over layers takes
!             care of itself.
              DO ll=1, n_list_up
                l=list_up(ll)
                weight_u(l, ir, id, k) &
                  =omega(l, i)*ls_sum_m(l, k)*geom_integ_m(l)
                weight_u(l, ir, id, k+n_red_eigensystem) &
                  =omega(l, i)*ls_sum_p(l, k)*geom_integ_p(l)
              ENDDO
            ENDDO
!
          ENDIF
!
!
!         Downward Radiation:
!         No layers below the current viewing level contribute here.
          IF (i <= i_rad_layer(ir)) THEN
!
!           Calculate the slantwise optical depths to the
!           boundaries of the layer. If the observing level lies
!           within the current layer we perform the calculation for
!           a layer reaching from the top of the current layer to
!           the observing level.
            IF (i < i_rad_layer(ir)) THEN
              DO ll=1, n_list_down
                l=list_down(ll)
                m_slant_depth_near(l) &
                  =frac_rad_layer(ir)*tau(l, i_rad_layer(ir))
              ENDDO
              DO ii=i_rad_layer(ir)-1, i+1, -1
                DO ll=1, n_list_down
                  l=list_down(ll)
                  m_slant_depth_near(l) &
                    =m_slant_depth_near(l)+tau(l, ii)
                ENDDO
              ENDDO
              DO ll=1, n_list_down
                l=list_down(ll)
                m_slant_depth_near(l) &
                  =m_slant_depth_near(l)/mu_v(l, id)
                m_slant_depth_inc(l)=tau(l, i)/mu_v(l, id)
                tau_i(l)=tau(l, i)
                frac_tau_i(l)=1.0e+00_RealK
              ENDDO
            ELSE
!             The viewing level lies in the current layer.
              DO ll=1, n_list_down
                l=list_down(ll)
                tau_i(l)=frac_rad_layer(ir)*tau(l, i)
                m_slant_depth_near(l)=0.0e+00_RealK
                m_slant_depth_inc(l)=tau_i(l)/mu_v(l, id)
                frac_tau_i(l)=frac_rad_layer(ir)
              ENDDO
            ENDIF
!
!
            IF (isolir == IP_solar) THEN
!             Set the geometrical terms for the solar integral.
              DO ll=1, n_list_down
                l=list_down(ll)
!               This may exhibit ill-conditioning, so it is perturbed
!               using L''Hopital's rule (actually we keep two terms in
!               the expansion).
                d_mu=mu_0(l)+mu_v(l, id)
                eta=eps_r/(d_mu+sign(sq_eps_r, d_mu))
                x=tau_i(l)/(mu_0(l)*mu_v(l, id))
                eta_nm=1.0_RealK-eta*x*(1.0_realk+0.5_realk*x*d_mu)
                geom_solar(l)=(mu_0(l)/(d_mu+eta)) &
                  *exp(m_slant_depth_near(l)) &
                  *(exp(-tau_i(l)/mu_0(l))*eta_nm &
                  -exp(m_slant_depth_inc(l)))
              ENDDO
!             Add the contribution of the particular integral to the
!             radiance. In this case there is no factor representing
!             transmission from the top of the layer, since that is
!             intrinsically 1.
              DO ll=1, n_list_down
                l=list_down(ll)
                radiance(l, ir, id) &
                  =radiance(l, ir, id)+azim_factor(l, id) &
                  *ls_sum_s(l)*omega(l, i)*geom_solar(l)
              ENDDO
            ELSE IF (isolir == IP_infra_red) THEN
              IF (ms == 0) THEN
                IF (l_ir_source_quad) THEN
                  print*, 'not done'
                ELSE
                  DO ll=1, n_list_down
                    l=list_down(ll)
!                   The azimuthal factor is omitted since it will be 1.
                    IF (m_slant_depth_inc(l) < -sq_eps_r) THEN
                      x=exp(m_slant_depth_near(l)) &
                      *(1.0e+00_RealK-exp(m_slant_depth_inc(l))) &
                      /m_slant_depth_inc(l)
                    ELSE
!                     Keep the first couple of terms from a power
!                     series.
                      x=-exp(m_slant_depth_near(l))*(1.0e+00_RealK &
                        +0.5e+00_RealK*m_slant_depth_inc(l))
                    ENDIF
                    radiance(l, ir, id) &
                      =radiance(l, ir, id) &
                      +(diff_planck(l, i)/pi)*x*frac_tau_i(l) &
                      /(1.0_RealK-omega(l, i)*phase_fnc(l, i, 1))
                  ENDDO
                ENDIF
              ENDIF
            ENDIF
!
!           Determine the contribution from each eigenvalue.
            DO k=1, n_red_eigensystem
!             The term for u^+:
              DO ll=1, n_list_down
                l=list_down(ll)
                geom_integ_p(l) &
                  =(mu(l, k)/(mu(l, k)-mu_v(l, id))) &
                  *exp(m_slant_depth_near(l)) &
                  *(exp(-(tau(l, i)-tau_i(l))/mu(l, k)) &
                  -exp(m_slant_depth_inc(l)-tau(l, i)/mu(l, k)))
!               The term for u^- may exhibit ill-conditioning,
!               so it is perturbed using L''Hopital's rule
!               (actually we keep two terms in the expansion).
                d_mu=mu(l, k)+mu_v(l, id)
                eta=eps_r/(d_mu+sign(sq_eps_r, d_mu))
                x=tau_i(l)/(mu(l, k)*mu_v(l, id))
                eta_nm=1.0_RealK-eta*x*(1.0_realk+0.5_realk*x*d_mu)
                geom_integ_m(l) &
                  =(mu(l, k)/(d_mu+eta)) &
                  *exp(m_slant_depth_near(l)) &
                  *(exp(-tau_i(l)/mu(l, k))*eta_nm &
                  -exp(m_slant_depth_inc(l)))
              ENDDO
!
!             Combine to form the weights for each element of the
!             solution.
              DO ll=1, n_list_down
                l=list_down(ll)
                weight_u(l, ir, id, k) &
                  =omega(l, i)*ls_sum_m(l, k)*geom_integ_m(l)
                weight_u(l, ir, id, k+n_red_eigensystem) &
                  =omega(l, i)*ls_sum_p(l, k)*geom_integ_p(l)
              ENDDO
!
            ENDDO
!
          ENDIF
!
!         Add on the contribution from the conditioning homogeneous
!         solution. This includes some redundant calculation when
!         the weights will be zero for layers which cannot contribute.
!         Eventually, it may be better to tidy this up.
          IF (isolir == IP_solar) THEN
!
            DO l=1, n_profile
              radiance(l, ir, id)=radiance(l, ir, id) &
                +azim_factor(l, id) &
                *weight_u(l, ir, id, k_sol(l))*upm_c(l, k_sol(l))
            ENDDO
!
          ELSE IF (isolir == IP_infra_red) THEN
!
            DO k=1, n_red_eigensystem
              DO l=1, n_profile
                radiance(l, ir, id)=radiance(l, ir, id) &
                  +azim_factor(l, id) &
                  *(weight_u(l, ir, id, k)*upm_c(l, k) &
                  +weight_u(l, ir, id, k+n_red_eigensystem) &
                  *upm_c(l, k+n_red_eigensystem))
              ENDDO
            ENDDO
!
          ENDIF
!
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SET_DIRN_WEIGHTS
!+ Subroutine to set level weights for calculating radiances.
!
! Purpose:
!   This routine yields the weights to be applied to the
!   solution of the equation for the complementary function.
!
! Method:
!
!   The particular integral is evaluated at each viewing level
!   within the current layer and weights are calculated for each
!   unknown.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE set_level_weights(i &
!                        Basic sizes
        , n_profile, ls_trunc, ms, n_red_eigensystem &
!                        Numerical arrays of spherical terms
        , cg_coeff, mu, eig_vec &
!                        Solar variables
        , isolir, z_sol, mu_0 &
!                        Infra-red variables
        , q_0, l_ir_source_quad, q_1 &
!                        Conditioning terms
        , upm_c, k_sol &
!                        Optical properies
        , tau, sqs2 &
!                        Levels where radiances are calculated
        , n_viewing_level, i_rad_layer, frac_rad_layer &
        , l_assign, i_assign_level &
!                        Output variables
        , c_ylm, weight_u &
!                        Dimensions
        , nd_profile, nd_viewing_level &
        , nd_max_order &
        , nd_red_eigensystem, nd_sph_cf_weight &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_viewing_level &
!           Allocated size for levels where radiances are calculated
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_red_eigensystem &
!           Size allocated for the reduced eigensystem
        , nd_sph_cf_weight
!           Size allocated for entities to be weighted by the C. F.
!
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric layers
        , n_red_eigensystem &
!           Size of the reduced eigensystem
        , i
!           Current layer
      INTEGER, Intent(IN) :: &
          ms &
!           Azimuthal order
        , ls_trunc
!           The truncating order of the system of equations
      INTEGER, Intent(IN) :: &
          isolir
!           Flag for spectral region
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile)
!           Optical depths of the layers
      REAL  (RealK), Intent(IN) :: &
          mu_0(nd_profile) &
!           Cosine of solar zenith angle
        , z_sol(nd_profile, ls_trunc+1-ms)
!           The direct solar radiance
      REAL  (RealK), Intent(IN) :: &
          q_0(nd_profile) &
!           Term for thermal particular integral
        , q_1(nd_profile)
!           Term for thermal particular integral
!
      INTEGER, Intent(IN) :: &
          k_sol(nd_profile)
!           Index of eigenvalue closest to the cosine of the solar
!           zenith angle
      REAL  (RealK), Intent(IN) :: &
          upm_c(nd_profile, 2*nd_red_eigensystem)
!           Weights for exponentials in conditioning term
!
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic source function in the IR
      LOGICAL, Intent(INOUT) :: &
          l_assign
!           Controlling logical for assigning levels
      INTEGER, Intent(INOUT) :: &
          i_assign_level
!           Current level where radiances are to be assigned
      REAL  (RealK), Intent(IN) :: &
          sqs2(nd_profile, 0: nd_max_order) &
!           S-coefficients
        , cg_coeff(ls_trunc+1-ms) &
!           Clebsch-Gordan coefficients
        , mu(nd_profile, nd_red_eigensystem) &
!           Eigenvaluse of the reduced system
        , eig_vec(nd_profile, 2*nd_red_eigensystem &
            , nd_red_eigensystem)
!           Eigenvectors of the full systems for positive eigenvalues
!           (these are scaled by the s-coefficients in the routine
!           EIG_SYS)
!
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!
      REAL  (RealK), Intent(INOUT) :: &
          c_ylm(nd_profile, nd_viewing_level, ls_trunc+1-ms)
!           Coefficients for radiances
      REAL  (RealK), Intent(OUT) :: &
        weight_u(nd_profile, nd_viewing_level, nd_sph_cf_weight &
            , 2*nd_red_eigensystem)
!           Weights to be applied to the vector U containing the
!           complementary functions
!
!
!     Local variables
      INTEGER &
          ivm &
!           Index for u^-
        , ivp
!           Index for u^+
      INTEGER &
          lsr &
!           Reduced polar order
        , m1ls &
!           -1^(l+m)
        , k &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          exp_minus(nd_profile, nd_red_eigensystem) &
!           Exponentials on viewing levels for negative terms
        , exp_plus(nd_profile, nd_red_eigensystem) &
!           Exponentials on viewing levels for positive terms
        , x_m(nd_profile) &
!           Work array connected with negative exponentials
        , x_p(nd_profile)
!           Work array connected with positive exponentials
!
!
!
      DO while (l_assign)
!
!       Calculate exponential terms for the whole routine for speed.
        DO k=1, n_red_eigensystem
          DO l=1, n_profile
            exp_minus(l, k) &
              =exp(-frac_rad_layer(i_assign_level)*tau(l) &
              /mu(l, k))
            exp_plus(l, k) &
              =exp((frac_rad_layer(i_assign_level)-1.0e+00_RealK) &
              *tau(l)/mu(l, k))
          ENDDO
        ENDDO
!
!       Add on the particular integral.
        IF (isolir == IP_solar) THEN
          DO l=1, n_profile
            x_m(l) &
              =exp(-frac_rad_layer(i_assign_level)*tau(l)/mu_0(l))
          ENDDO
          DO lsr=1, ls_trunc-ms+1
            DO l=1, n_profile
              c_ylm(l, i_assign_level, lsr) &
                =c_ylm(l, i_assign_level, lsr)+x_m(l)*z_sol(l, lsr)
            ENDDO
          ENDDO
!
!         Add on the homogeneous conditioning solution.
          DO l=1, n_profile
            x_m(l)=upm_c(l, k_sol(l))*exp_minus(l, k_sol(l))
          ENDDO
          DO lsr=1, ls_trunc-ms+1
            m1ls=real(1-2*mod((lsr-1),2), RealK)
            DO l=1, n_profile
              c_ylm(l, i_assign_level, lsr) &
                =c_ylm(l, i_assign_level, lsr)+x_m(l)*m1ls &
                *eig_vec(l, lsr, k_sol(l))
            ENDDO
          ENDDO
!
        ELSE IF (isolir == IP_infra_red) THEN
!
          IF (ms == 0) THEN
!
            IF (l_ir_source_quad) THEN
!
              DO l=1, n_profile
                c_ylm(l, i_assign_level, 1) &
                  =c_ylm(l, i_assign_level, 1) &
                  +cg_coeff(1)*q_1(l)/sqs2(l, 0)
                c_ylm(l, i_assign_level, 2) &
                  =c_ylm(l, i_assign_level, 2) &
                  +q_0(l)+q_1(l) &
                  *(frac_rad_layer(i_assign_level)-0.5e+00_RealK)
              ENDDO
              IF (ls_trunc > 1) THEN
                DO l=1, n_profile
                  c_ylm(l, i_assign_level, 3) &
                    =c_ylm(l, i_assign_level, 3) &
                    *cg_coeff(2)*q_1(l)/sqs2(l, 2)
                ENDDO
              ENDIF
!
            ELSE
!
              DO l=1, n_profile
                c_ylm(l, i_assign_level, 2) &
                  =c_ylm(l, i_assign_level, 2)+q_0(l)
              ENDDO
!
!             Now add on the homogeneous conditioning solution.
              DO k=1, n_red_eigensystem
                DO l=1, n_profile
                  x_m(l)=upm_c(l, k)*exp_minus(l, k)
                  x_p(l)=upm_c(l, k+n_red_eigensystem)*exp_plus(l, k)
                ENDDO
                DO lsr=1, ls_trunc+1-ms
                  m1ls=real(1-2*mod(lsr-1, 2), RealK)
!                 Increment subsequent terms.
                  DO l=1, n_profile
                    c_ylm(l, i_assign_level, lsr) &
                      =c_ylm(l, i_assign_level, lsr) &
                      +(x_m(l)*m1ls+x_p(l))*eig_vec(l, lsr, k)
                  ENDDO
                ENDDO
              ENDDO
            ENDIF
          ENDIF
!
        ENDIF
!
!       Calculate the appropriate weights.
        DO k=1, n_red_eigensystem
!         Variable numbers:
          ivm=k
          ivp=ivm+n_red_eigensystem
          DO lsr=1, ls_trunc+1-ms
            m1ls=real(1-2*mod((lsr-1),2), RealK)
            DO l=1, n_profile
              weight_u(l, i_assign_level, lsr, ivm) &
                =eig_vec(l, lsr, k)*exp_minus(l, k)*m1ls
              weight_u(l, i_assign_level, lsr, ivp) &
                =eig_vec(l, lsr, k)*exp_plus(l, k)
            ENDDO
          ENDDO
        ENDDO
!
!       Increment the level for assignments:
        i_assign_level=i_assign_level+1
        IF (i_assign_level <= n_viewing_level) THEN
          IF (i_rad_layer(i_assign_level) > i) l_assign=.false.
        ELSE
          l_assign=.false.
        ENDIF
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SET_LEVEL_WEIGHTS
!+ Subroutine to set the pentadiagonal matrix for the fluxes.
!
! Method:
!       Straightforward.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE set_matrix_pentadiagonal(n_profile, n_layer &
         , trans, reflect &
         , s_down, s_up &
         , diffuse_albedo, direct_albedo &
         , flux_direct_ground, flux_inc_down &
         , d_planck_flux_surface &
         , a5, b &
         , nd_profile, nd_layer &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           SIze allocated for atmospheric profiles
        , nd_layer
!           SIze allocated for atmospheric layers
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
      REAL  (RealK), Intent(IN) :: &
          trans(nd_profile, nd_layer) &
!           Transmission coefficient
        , reflect(nd_profile, nd_layer) &
!           Reflection coefficient
        , s_down(nd_profile, nd_layer) &
!           Downward diffuse source
        , s_up(nd_profile, nd_layer) &
!           Upward diffuse source
        , diffuse_albedo(nd_profile) &
!           Diffuse surface albedo
        , direct_albedo(nd_profile) &
!           Direct surface albedo
        , d_planck_flux_surface(nd_profile) &
!           Difference in Planckian fluxes at the surface
        , flux_inc_down(nd_profile) &
!           Incident total flux
        , flux_direct_ground(nd_profile)
!           Direct flux at ground level
      REAL  (RealK), Intent(OUT) :: &
          a5(nd_profile, 5, 2*nd_layer+2) &
!           Pentadiagonal matrix
        , b(nd_profile, 2*nd_layer+2)
!           Source terms for equations
!
!     Declaration of local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!
!
!     The top boundary condition:
      DO l=1, n_profile
        a5(l, 4, 2)=0.0e+00_RealK
        a5(l, 3, 2)=1.0e+00_RealK
        a5(l, 2, 2)=0.0e+00_RealK
        a5(l, 1, 2)=0.0e+00_RealK
        b(l, 2)=flux_inc_down(l)
      ENDDO
!
!     Interior rows: odd and even rows correspond to different boundary
!     conditions.
      DO i=1, n_layer
        DO l=1, n_profile
!
          a5(l, 5, 2*i-1)=0.0e+00_RealK
          a5(l, 4, 2*i-1)=0.0e+00_RealK
          a5(l, 3, 2*i-1)=-1.0e+00_RealK
          a5(l, 2, 2*i-1)=reflect(l, i)
          a5(l, 1, 2*i-1)=trans(l, i)
          b(l, 2*i-1)=-s_up(l, i)
!
          a5(l, 5, 2*i+2)=trans(l, i)
          a5(l, 4, 2*i+2)=reflect(l, i)
          a5(l, 3, 2*i+2)=-1.0e+00_RealK
          a5(l, 2, 2*i+2)=0.0e+00_RealK
          a5(l, 1, 2*i+2)=0.0e+00_RealK
          b(l, 2*i+2)=-s_down(l, i)
!
        ENDDO
      ENDDO
!
!     The surface boundary condition:
      DO l=1, n_profile
        a5(l, 5, 2*n_layer+1)=0.0e+00_RealK
        a5(l, 4, 2*n_layer+1)=0.0e+00_RealK
        a5(l, 3, 2*n_layer+1)=1.0e+00_RealK
        a5(l, 2, 2*n_layer+1)=-diffuse_albedo(l)
        b(l, 2*n_layer+1) &
          =(1.0e+00_RealK-diffuse_albedo(l))*d_planck_flux_surface(l) &
          +(direct_albedo(l)-diffuse_albedo(l)) &
          *flux_direct_ground(l)
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SET_MATRIX_PENTADIAGONAL
!+ Subroutine to set moist aerosol properties independent of bands.
!
! Method:
!        The mean relative humidities are calculated and pointers to
!        the lookup tables are set.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE set_moist_aerosol_properties(ierr &
        , n_profile, n_layer &
        , n_aerosol, i_aerosol_parametrization, nhumidity &
        , water_mix_ratio, t, p, delta_humidity &
        , mean_rel_humidity, i_humidity_pointer &
        , nd_profile, nd_layer, nd_aerosol_species &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE aerosol_parametrization_pcf
      USE def_std_io_icf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , nd_aerosol_species
!           Maximum number of aerosols
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_aerosol &
!           Number of aerosol species
        , i_aerosol_parametrization(nd_aerosol_species) &
!           Parametrizations of aerosol species
        , nhumidity(nd_aerosol_species)
!           Number of humidity values
      INTEGER, Intent(OUT) :: &
          i_humidity_pointer(nd_profile, nd_layer)
!           Pointers to look-up tables
      REAL  (RealK), Intent(IN) :: &
          water_mix_ratio(nd_profile, nd_layer) &
!           Mixing ratio of water vapour
        , t(nd_profile, nd_layer) &
!           Temperatures
        , p(nd_profile, nd_layer)
!           Pressures
      REAL  (RealK), Intent(OUT) :: &
          mean_rel_humidity(nd_profile, nd_layer) &
!           Mean humidities of layers
        , delta_humidity
!           Increment in humidity
!
!
!     local variables.
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , l &
!           Loop variable
        , nhumidity_common
!           Common number of humidities for moist aerosols
      REAL  (RealK) :: &
          mix_ratio_sat(nd_profile, nd_layer)
!           Saturated humidity mixing ratio
!
!     Subroutines called:

!      EXTERNAL &
!          qsat_gill





!
!
!
!     Set up array of pointers to `include'' the effects of humidity.
!     Calculate the saturated mixing ratio.

      CALL qsat_gill(mix_ratio_sat, t, p &
        , n_profile, n_layer &
        , nd_profile, nd_layer)







!
!     Determine the number of humidities to be used for moist
!     aerosols. This must be the same for all moist aerosols
!     in the current version of the code.
      nhumidity_common=0
      DO j=1, n_aerosol
        IF (i_aerosol_parametrization(j) == IP_aerosol_param_moist) &
             THEN
          IF (nhumidity(j) > 0) THEN
!           Set the actual common value.
            IF (nhumidity_common == 0) THEN
              nhumidity_common=nhumidity(j)
            ELSE IF (nhumidity(j) /= nhumidity_common) THEN
!             There is an inconsistency.
              WRITE(iu_err, '(/a)') &
                '*** Error: The look-up tables for moist aerosols ' &
                , 'are of different sizes. tgis is not permitted.'
              ierr=i_err_fatal
              RETURN
            ENDIF
          ENDIF
        ENDIF
      ENDDO
!     The look-up table is assumed to be uniform in humidity.
      delta_humidity=1.0e+00_RealK &
        /(real(nhumidity_common, RealK)-1.0e+00_realk)
      DO i=1, nd_layer
        DO l=1, nd_profile
          mean_rel_humidity(l, i) &
            =water_mix_ratio(l, i)*(1.0e+00_RealK-mix_ratio_sat(l, i)) &
            /((1.0e+00_RealK-water_mix_ratio(l, i))*mix_ratio_sat(l, i))
!         Check that the mean relative humidity
!         does not exceed or equal 1.0.
          mean_rel_humidity(l, i)=min(mean_rel_humidity(l, i) &
            , 9.9999e-01_RealK)
          i_humidity_pointer(l, i)=1 &
            +int(mean_rel_humidity(l, i)*(nhumidity_common-1))
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SET_MOIST_AEROSOL_PROPERTIES
!+ Function to set number of source coefficients.
!
! Method:
!        The two-stream approximation is examined and the number
!        of coefficients is set accordingly.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77 with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      FUNCTION set_n_source_coeff(isolir, l_ir_source_quad &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
!
!
      IMPLICIT NONE
!
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Flag for quadratic infra-red source
!
      INTEGER :: &
          set_n_source_coeff
!           Returned number of source coefficients
!
!
!
      IF (isolir == IP_solar) THEN
        set_n_source_coeff=2
      ELSE
        IF (l_ir_source_quad) THEN
          set_n_source_coeff=2
        ELSE
          set_n_source_coeff=1
        ENDIF
      ENDIF
!
!
!
      RETURN
      END FUNCTION SET_N_SOURCE_COEFF
!+ Subroutine to set the layers in which radiances are required.
!
! Purpose:
!   This determines the layers of the atmosphere where the analytic
!   expression for the radiance must be intercepted to give values
!   on the correct levels.
!
! Method:
!   Straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE set_rad_layer(ierr &
        , n_layer, n_viewing_level, viewing_level &
        , i_rad_layer, frac_rad_layer &
        , nd_viewing_level &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE error_pcf
      USE def_std_io_icf
!
!
      IMPLICIT NONE
!
!
      INTEGER, Intent(IN) :: &
          nd_viewing_level
!           Size allocated for levels where radiances are calculated
!
!     Header files
!
!
!     Dummy arguments
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels on which to calculate the radiance
        , n_layer
!           Number of atmospheric layers
      REAL  (RealK), Intent(IN) :: &
          viewing_level(nd_viewing_level)
!           Levels where radiances are calculated
      INTEGER, Intent(OUT) :: &
          i_rad_layer(nd_viewing_level)
!           Layers in which to intercept radiances
      REAL  (RealK), Intent(OUT) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers where radiances
!           are calculated
!
!
!     Local Variables
      INTEGER &
          i
!           Loop variable
      REAL  (RealK) :: &
          tol_bdy
!           The tolerance detecting the closeness of boundaries
!
!
!
!     Set the tolerance for detecting boundaries.
      tol_bdy=1.6e+01_RealK*epsilon(tol_bdy)
!
      DO i=1, n_viewing_level
!
!       Check that a level is not above the top of the atmosphere.
        IF (viewing_level(i) < 0.0e+00_RealK) THEN
          WRITE(iu_err, '(/a)') &
            '*** Error: A viewing level is above the TOA.'
          ierr=i_err_fatal
          RETURN
        ENDIF
!
        i_rad_layer(i)=int(viewing_level(i))+1
        frac_rad_layer(i)=1.0e+00_RealK+viewing_level(i) &
          -real(i_rad_layer(i), RealK)
!
!       At the bottom of the atmosphere this will give a value greater
!       than N_LAYER, so we reset, but check that an unreasonable
!       attempt to get radiances below the column has not been made:
!       this will give a fatal error.
        IF (i_rad_layer(i) > n_layer) THEN
          IF (frac_rad_layer(i) < tol_bdy) THEN
            i_rad_layer(i)=i_rad_layer(i)-1
            frac_rad_layer(i)=1.0e+00_RealK
          ELSE
            WRITE(iu_err, '(/a)') &
              '*** Error: A viewing level is below the surface.'
            ierr=i_err_fatal
            RETURN
          ENDIF
        ENDIF
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SET_RAD_LAYER
!+ Subroutine to set arrays describing the spherical truncation.
!
! Purpose:
!   This routine sets an arrays of pointers to control the allocation
!   of memory.
!
! Method:
!   Straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE set_truncation(ierr &
        , i_truncation, ls_global_trunc &
        , ls_max_order, ls_local_trunc &
        , ms_min, ms_max, ms_trunc &
        , ia_sph_mm, n_order_phase &
        , nd_max_order &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE sph_truncation_pcf
      USE error_pcf
      USE def_std_io_icf
!
!
      IMPLICIT NONE
!
!
      INTEGER, Intent(IN) :: &
          nd_max_order
!           Size allocated for orders of spherical harmonics
!
!     Header files
!
!
!     Dummy arguments
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          i_truncation &
!           Type of spherical truncation
        , ls_global_trunc &
!           Global order of truncation
        , ms_min &
!           Lowest value of of the azimuthal order calculated
        , ms_max
!           Highest value of of the azimuthal order calculated
      INTEGER, Intent(OUT) :: &
          ls_max_order &
!           Maximum order of spherical harmonic terms required
        , ls_local_trunc(0: nd_max_order) &
!           Truncating order for individual azimuthal quantum numbers
        , ms_trunc(0: nd_max_order) &
!           Maximum azimuthal quantum number for each order
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficients of (m, m) for each m
        , n_order_phase
!           Order of terms in the phase function to be used in
!           direct calculation of spherical harmonics
!
!
!     Local Variables
      INTEGER &
          ls &
!           Order of spherical harmonic
        , ms
!           Azimuthal order of spherical harmonic
!
!     Subroutines called:
!      EXTERNAL &
!          eval_uplm
!
!
!
!     Carry out a preliminary check that the truncation is appropriate.
      IF ( (i_truncation == IP_trunc_azim_sym).AND. &
         (ms_max > 0) ) THEN
!
        WRITE(iu_err, '(/a)') &
          '*** Error: An azimuthally symmetric truncation is not ' &
          //'appropriate IF ms_max > 0.'
        ierr=i_err_fatal
        RETURN
!
      ENDIF
!
      IF ( (i_truncation == IP_trunc_triangular).OR. &
         (i_truncation == IP_trunc_adaptive) ) THEN
!
!       Set the characteristics for a triangular truncation:
!       azimuthal orders from MS_MIN to MS_MAX are needed.
!       In order to keep an even number of harmonics for all
!       azimuthal orders, the maximum order must be set
!       1 greater than the (odd) order of the truncation. In
!       addition, an extra order beyond the truncation for the
!       particular m is required for the case of solar radiation.
!       ("+4" appears in the loop below because MS is one greater
!       then the order for which space is being reserved.) Note
!       finally that space is allocated for the unused harmonic
!       LS_GLOBAL_TRUNC+2 for even values of MS just to keep the
!       programming simple.
!
!       The adaptive truncation comes here as well since the maximum
!       conceivable number of harmonics might be required for each
!       azimuthal order.
        ls_max_order=ls_global_trunc+1
        ms_trunc(ms_min)=ms_min
        DO ls=ms_min+1, ls_max_order
          ms_trunc(ls)=min(min(ms_max, ls), ls_global_trunc)
        ENDDO
        ia_sph_mm(ms_min)=1
        DO ms=ms_min+1, ms_max
          ia_sph_mm(ms)=ia_sph_mm(ms-1)+ls_global_trunc+4-ms
        ENDDO
!       For each MS an even number of terms must be calculated. The
!       global truncation will be odd.
        DO ms=ms_min, ms_max
          ls_local_trunc(ms)=ls_global_trunc+mod(ms, 2)
        ENDDO
!
      ELSE IF (i_truncation == IP_trunc_rhombohedral) THEN
!
!       Set the characteristics for a rhombohedral truncation.
!       If calculation begins with an odd azimuthal order, one
!       extra order will be required to ensure that even of polar
!       orders are calculated.
        ls_max_order=ls_global_trunc+mod(ms_min, 2)
!       N.B. If LS_MAX_ORDER is ever changed, make sure that the
!       following code is still valid. Here LS_MAX_ORDER logically
!       means LS_GLOBAL_TRUNC+MOD(MS_MIN, 2).
!
!       Reset the maximum azimuthal order if it has been set too high
        ms_trunc(ms_min)=ms_min
        DO ls=ms_min+1, ls_max_order
          ms_trunc(ls)=min(ms_max, min(ls_max_order-ls+ms_min, ls))
        ENDDO
        ia_sph_mm(ms_min)=1
!       The "+4" rather than "+3" below allows for the fact that the
!       requisite number of harmonics does not fall off exactly
!       linearly with the azimuthal order, but does so in steps.
        DO ms=ms_min+1, ms_max
          ia_sph_mm(ms)=ia_sph_mm(ms-1) &
            +ls_global_trunc+4+ms_min-2*ms+1
        ENDDO
!       For each MS an even number of terms must be calculated. The
!       global truncation will be odd.
        DO ms=ms_min, ms_max
          ls_local_trunc(ms)=ls_global_trunc &
            +mod(ms_min, 2)-(ms-ms_min)
        ENDDO
!
      ELSE IF (i_truncation == IP_trunc_azim_sym) THEN
!
!       Set the characteristics for an azimuthally symmetric truncation.
!       This will be the normal case in the infra-red region.
        ls_max_order=ls_global_trunc
        ms_trunc(0)=0
        ia_sph_mm(0)=1
        DO ls=1, ls_max_order
          ms_trunc(ls)=0
        ENDDO
!       Set the address of one extra order for use with solar sources.
        ls_local_trunc(0)=ls_global_trunc
!
      ELSE
!
        WRITE(iu_err, '(/a)') &
          '***Error: An illegal truncation has been requested.'
        ierr=i_err_fatal
        RETURN
!
      ENDIF
!
!     Calculate enough terms of the phase function to satsify the
!     truncation at every azimuthal order.
      n_order_phase=1
      DO ms=ms_min, ms_max
        n_order_phase=max(n_order_phase, ls_local_trunc(ms))
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SET_TRUNCATION
!+ Subroutine to perform a shell sort.
!
! Method:
!        The standard shell sorting algorithm is implemented.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE shell_sort(n, pointer, key)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n
!           Number of elements
      INTEGER, Intent(INOUT) :: &
          pointer(n)
!           Pointer to succeeding elements
      REAL  (RealK), Intent(IN) :: &
          key(n)
!           Key for sorting
!
!     Local variables.
      INTEGER &
          gap &
!           Searching interval
        , pointer_temp &
!           Temporary value of pointer
        , j &
!           Loop variable
        , k
!           Loop variable
!
!
      IF (n == 1) THEN
        pointer(1)=1
        RETURN
      ENDIF
!
      gap=n
      DO WHILE(gap >= 2)
        gap=gap/2
        DO j=gap, n-1
          DO k=j-gap+1, 1, -gap
            IF (key(pointer(k)) > key(pointer(k+gap))) THEN
                    pointer_temp=pointer(k)
              pointer(k)=pointer(k+gap)
              pointer(k+gap)=pointer_temp
            ENDIF
          ENDDO
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SHELL_SORT
!+ Subroutine to calculate the singly scattered solar radiance.
!
! Purpose:
!   This subroutine is used to increment the radiances in the
!   required directions on the viewing levels with the singly
!   scattered solar radiance.
!
! Method:
!   Each direction is considered in turn. For each layer of the
!   atmosphere an angular factor involving the phase function
!   and for each viewing level a geometric factor involving the
!   optical depth between the layer in question and the viewing
!   level is calculated. The product of these with the solar
!   beam gives the contribution of that layer to the increment
!   to the radiance.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE single_scat_sol(n_profile, n_layer &
        , n_direction, direction &
        , n_viewing_level, i_rad_layer, frac_rad_layer &
        , i_direct, mu_0 &
        , tau, omega, phase_fnc_solar &
        , radiance &
        , nd_profile, nd_radiance_profile &
        , nd_layer, nd_direction, nd_viewing_level &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE math_cnst_ccf
!
!
      IMPLICIT NONE
!
!
!     Dummy arguments:
!     Sizes of arrays:
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_radiance_profile &
!           Size allocated for atmospheric profiles where radiances
!           are calculated
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_viewing_level &
!           Size allocated for viewing levels
        , nd_direction
!           Size allocated for viewing directions
!
!
!     Atmospheric structure:
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric profiles
        , n_layer
!           Number of atmospheric layers
!
!     Viewing geometry:
      INTEGER, Intent(IN) :: &
          n_direction &
!           Number of directions
        , n_viewing_level &
!           Number of levels where the radiance is calculated
        , i_rad_layer(nd_viewing_level)
!           Indices of layers containing viewing levels
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2) &
!           Cosines of polar viewing angles
        , frac_rad_layer(nd_viewing_level)
!           Fraction optical depth into its layer of the viewing level
!
!     Solar Radiances
      REAL  (RealK), Intent(IN) :: &
          i_direct(nd_profile, 0: nd_layer) &
!           Direct solar radiances
        , mu_0(nd_profile)
!           Cosines of solar zenith angles
!
!     Optical properties of the atmosphere
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, nd_layer) &
!           Optical depths
        , omega(nd_profile, nd_layer) &
!           Albedos of single scattering
        , phase_fnc_solar(nd_radiance_profile, nd_layer, nd_direction)
!           Phase function
!
!
      REAL  (RealK), Intent(INOUT) :: &
          radiance(nd_radiance_profile, nd_viewing_level, nd_direction)
!           Radiances
!
!
!     Local variables
      INTEGER &
          l &
!           Loop variable (points)
        , ll &
!           Loop variable
        , i &
!           Loop variable
        , ii &
!           Loop variable
        , ir &
!           Loop variable (radiative levels)
        , id
!           Loop variable (directions)
      INTEGER &
          n_list_up &
!           Numbers of points where the current viewing direction
!           points up
        , list_up(nd_profile) &
!           List up points with where the current viewing direction
!           points up
        , n_list_down &
!           Numbers of points where the current viewing direction
!           points down
        , list_down(nd_profile)
!           List up points with where the current viewing direction
!           points up
      REAL  (RealK) :: &
          geom(nd_profile) &
!           Geometrical factor
        , m_slant_depth_near(nd_profile) &
!           Minus slantwise optical distance between the radiance
!           level and the nearer boundary of the current layer
        , m_slant_depth_far(nd_profile) &
!           Minus slantwise optical distance between the radiance
!           level and the farther boundary of the current layer
        , tau_i(nd_profile) &
!           Optical depth of the relevant part of the current layer
        , trans_d(nd_profile) &
!           Direct transmission from the layer containing the viewing
!           level to the viewung level
        , d_mu
!           Difference in cosines of directions
!
!     Variables related to the treatment of ill-conditioning
      REAL  (RealK) :: &
          eps_r &
!           The smallest real number such that 1.0-EPS_R is not 1
!           to the computer''s precision
        , sq_eps_r &
!           The square root of the above
        , eta &
!           The conditioning weight
        , eta_nm
!           The conditioning multiplier applied in the numerator
!
!
!
!     Set the tolerances used in avoiding ill-conditioning, testing
!     on any variable.
      eps_r=epsilon(mu_0(1))
      sq_eps_r=sqrt(eps_r)
!
!     Consider each direction in turn. Collect points where the
!     viewing direction is upward and points where it is downward,
!     then calculate the angular and geometric factors.
      DO id=1, n_direction
!
!       Collect points where the viewing direction is upward:
!       (Horizontal directions are not allowed).
        n_list_up=0
        DO l=1, n_profile
          IF (direction(l, id, 1) > 0.0e+00_RealK) THEN
            n_list_up=n_list_up+1
            list_up(n_list_up)=l
          ENDIF
        ENDDO
!
!       Collect points where the viewing direction is downward:
        n_list_down=0
        DO l=1, n_profile
          IF (direction(l, id, 1) < 0.0e+00_RealK) THEN
            n_list_down=n_list_down+1
            list_down(n_list_down)=l
          ENDIF
        ENDDO
!
!       Go through each atmospheric layer calculating the radiance
!       at each observing level.
        DO i=1, n_layer
!
!         Calculate the geometric factors:
          DO ir=1, n_viewing_level
!
!           Upward Radiances:
!           Contributions arise only from layers below the viewing
!           level.
            IF (i >= i_rad_layer(ir)) THEN
!
!             Calculate minus the slantwise optical depths to the
!             boundaries of the layer. If the level where the radiance
!             is required lies in the current layer we perform the
!             calculation for a temporary layer reaching from the
!             viewing level to the bottom of the current layer.
              IF (i > i_rad_layer(ir)) THEN
!               Full layers are required.
                DO ll=1, n_list_up
                  l=list_up(ll)
                  m_slant_depth_near(l) &
                    =(1.0e+00_RealK-frac_rad_layer(ir)) &
                    *tau(l, i_rad_layer(ir))
                ENDDO
                DO ii=i_rad_layer(ir)+1, i-1
                  DO ll=1, n_list_up
                    l=list_up(ll)
                    m_slant_depth_near(l) &
                     =m_slant_depth_near(l)+tau(l, ii)
                  ENDDO
                ENDDO
                DO ll=1, n_list_up
                  l=list_up(ll)
                  m_slant_depth_near(l) &
                    =-m_slant_depth_near(l)/direction(l, id, 1)
                  m_slant_depth_far(l)=m_slant_depth_near(l) &
                    -tau(l, i)/direction(l, id, 1)
!                 Collect the local optical depth to allow the use of
!                 generic code later.
                  tau_i(l)=tau(l, i)
                  trans_d(l)=1.0e+00_RealK
                ENDDO
              ELSE IF (i == i_rad_layer(ir)) THEN
!               The viewing level lies in the current layer.
                DO ll=1, n_list_up
                  l=list_up(ll)
                  m_slant_depth_near(l)=0.0e+00_RealK
                  m_slant_depth_far(l) &
                    =-(1.0e+00_RealK-frac_rad_layer(ir))*tau(l, i) &
                    /direction(l, id, 1)
                  tau_i(l)=(1.0e+00_RealK-frac_rad_layer(ir))*tau(l, i)
                  trans_d(l) &
                    =exp(-frac_rad_layer(ir)*tau(l, i)/mu_0(l))
                ENDDO
              ENDIF
!
!
!             Set the geometrical term and increment the radiance.
              DO ll=1, n_list_up
                l=list_up(ll)
                geom(l)=(mu_0(l)/(mu_0(l)+direction(l, id, 1))) &
                  *(exp(m_slant_depth_near(l)) &
                  -exp(m_slant_depth_far(l)-tau_i(l)/mu_0(l)))
                radiance(l, ir, id)=radiance(l, ir, id) &
                  +i_direct(l, i-1)*trans_d(l)*geom(l)*(omega(l, i) &
                  /(4.0e+00_RealK*pi))*phase_fnc_solar(l, i, id)
              ENDDO
!
            ENDIF
!
!
!           Downward Radiances:
!           Contributions arise only from layers above the viewing
!           level.
            IF (i <= i_rad_layer(ir)) THEN
!
!             Calculate the slantwise optical depths to the
!             boundaries of the layer. If the observing level lies
!             within the current layer we perform the calculation for
!             a layer reaching from the top of the current layer to
!             the observing level.
              IF (i < i_rad_layer(ir)) THEN
                DO ll=1, n_list_down
                  l=list_down(ll)
                  m_slant_depth_near(l) &
                  =frac_rad_layer(ir)*tau(l, i_rad_layer(ir))
                ENDDO
                DO ii=i_rad_layer(ir)-1, i+1, -1
                  DO ll=1, n_list_down
                    l=list_down(ll)
                    m_slant_depth_near(l) &
                      =m_slant_depth_near(l)+tau(l, ii)
                  ENDDO
                ENDDO
                DO ll=1, n_list_down
                  l=list_down(ll)
                  m_slant_depth_near(l) &
                    =m_slant_depth_near(l)/direction(l, id, 1)
                  m_slant_depth_far(l)=m_slant_depth_near(l) &
                    +tau(l, i)/direction(l, id, 1)
                  tau_i(l)=tau(l, i)
                ENDDO
              ELSE
!               The viewing level lies in the current layer.
                DO ll=1, n_list_down
                  l=list_down(ll)
                  tau_i(l)=frac_rad_layer(ir)*tau(l, i)
                  m_slant_depth_near(l)=0.0e+00_RealK
                  m_slant_depth_far(l)=tau_i(l)/direction(l, id, 1)
                ENDDO
              ENDIF
!
!
!             Set the geometrical terms for the solar integral.
              DO ll=1, n_list_down
                l=list_down(ll)
!               This may exhibit ill-conditioning, so it is perturbed
!               using L''Hopital's rule.
                d_mu=mu_0(l)+direction(l, id, 1)
                eta=eps_r/(d_mu+sign(sq_eps_r, d_mu))
                eta_nm=(1.0e+00_RealK-eta*tau_i(l) &
                  /(mu_0(l)*direction(l, id, 1)))
                geom(l)=(mu_0(l)/(d_mu+eta)) &
                  *(exp(m_slant_depth_near(l)-tau_i(l)/mu_0(l)) &
                  *eta_nm &
                  -exp(m_slant_depth_far(l)))
                radiance(l, ir, id)=radiance(l, ir, id) &
                  +i_direct(l, i-1)*geom(l) &
                  *(omega(l, i)/(4.0e+00_RealK*pi)) &
                  *phase_fnc_solar(l, i, id)
              ENDDO
!
            ENDIF
!
          ENDDO
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SINGLE_SCAT_SOL
!+ Subroutine to find single scattering properties of all regions.
!
! Method:
!        Straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE single_scattering_all(i_scatter_method_band &
!                        Atmospheric Properties
        , n_profile, n_layer, d_mass &
!                        Cloudy Properties
        , l_cloud, n_cloud_top, n_cloud_type &
!                       Optical Properties
        , ss_prop &
        , k_gas_abs &
!                        Dimensions of Arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct &
        )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , nd_layer_clr &
!           Size allocated for completely clear layers
        , id_ct
!           Topmost declared cloudy layer
!
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          i_scatter_method_band
!           Treatment of scattering in the band
!
!                        Atmospheric properties
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
      REAL  (RealK), Intent(IN) :: &
          d_mass(nd_profile, nd_layer)
!           Mass thickness of each layer
!
!                        Cloudy properties
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Flag for clouds
      INTEGER, Intent(IN) :: &
          n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_type
!           Number of types of clouds
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!                        Optical properties
      REAL  (RealK), Intent(IN) :: &
          k_gas_abs(nd_profile, nd_layer)
!           Gaseous extinction
!
!
!
!     Local variables.
      INTEGER &
          k
!           Loop variable
!
!     Subroutines called:
!      EXTERNAL &
!          single_scattering
!
!
!
!     Clear-sky properties:
!
!     In the following call K_GAS_ABS can be used as if it had the
!     smaller dimension ND_LAYER_CLR as long as the last dimension
!     is over atmospheric layers.
!
      IF (l_cloud) THEN
!CDIR COLLAPSE
        DO k=0, n_cloud_type
          CALL single_scattering(i_scatter_method_band &
            , n_profile, 1, n_layer &
            , d_mass &
            , ss_prop%k_grey_tot(:, :, k) &
            , ss_prop%k_ext_scat(:, :, k) &
            , k_gas_abs &
            , ss_prop%tau(:, :, k), ss_prop%omega(:, :, k) &
            , nd_profile, nd_layer, id_ct, nd_layer &
            )
        ENDDO
      ELSE
!CDIR COLLAPSE
        CALL single_scattering(i_scatter_method_band &
          , n_profile, 1, n_layer &
          , d_mass &
          , ss_prop%k_grey_tot(:, :, 0) &
          , ss_prop%k_ext_scat(:, :, 0) &
          , k_gas_abs &
          , ss_prop%tau(:, :, 0), ss_prop%omega(:, :, 0) &
          , nd_profile, nd_layer, id_ct, nd_layer &
          )
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE SINGLE_SCATTERING_ALL
!+ Subroutine to find the optical depth and single scattering albedo.
!
! Method:
!        Depending on the treatment of scattering, the optical and
!        and single scattering albedo are determined from the
!        extinctions supplied.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE single_scattering(i_scatter_method_band &
        , n_profile, i_first_layer, i_last_layer &
        , d_mass &
        , k_grey_tot, k_ext_scat, k_gas_abs &
        , tau, omega &
        , nd_profile, nd_layer, id_lt, id_lb &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE scatter_method_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , id_lt &
!           Topmost declared layer for optical properties
        , id_lb
!           Bottom declared layer for optical properties
!
!     Inclusion of header files.
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          i_scatter_method_band
!           Treatment of scattering in this band
!
!                        Atmospheric properties
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
!           Number of layers
        , i_first_layer &
!           First layer to consider
        , i_last_layer
!           Last layer to consider
      REAL  (RealK), Intent(IN) :: &
          d_mass(nd_profile, nd_layer)
!           Mass thickness of each layer
!
!                        Optical properties
      REAL  (RealK), Intent(IN) :: &
          k_grey_tot(nd_profile, id_lt: id_lb) &
!           Absorptive extinction
        , k_ext_scat(nd_profile, id_lt: id_lb) &
!           Scattering extinction
        , k_gas_abs(nd_profile, nd_layer)
!           Gaseous extinction
!
!                        Single scattering properties
      REAL  (RealK), Intent(OUT) :: &
          tau(nd_profile, id_lt: id_lb) &
!           Optical depth
        , omega(nd_profile, id_lt: id_lb)
!           Single scattering albedo
!
!
!
!     Local variables.
      INTEGER &
          l &
!           Loop variable
        , i
!           Loop variable
!
      REAL  (RealK) :: &
          k_total(nd_profile, id_lt: id_lb) 
!           Total extinction including gaseous contributions
!
!     Variables related to the treatment of ill-conditioning
      REAL  (RealK) :: &
          eps_r
!           The smallest real number such that 1.0-EPS_R is not 1
!           to the computer''s precision
!
!     Set the tolerances used in avoiding ill-conditioning, testing
!     on any variable.
      eps_r=epsilon(tau(1, 1))
!
!     The machine tolerance is added to the denominator in the
!     expression for omega to prevent division by zero: this is
!     significant only if the total extinction is small, and thus
!     will not sensibly affect any physical results.
!
      IF (i_scatter_method_band == IP_scatter_full) THEN
!
!CDIR COLLAPSE
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            k_total(l, i)=k_grey_tot(l, i)+k_gas_abs(l, i)
          ENDDO
        ENDDO
!CDIR COLLAPSE
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            tau(l, i)=k_total(l, i)*d_mass(l, i)
            IF (k_total(l, i) > 0.0_RealK) THEN
              omega(l, i)=k_ext_scat(l, i)/k_total(l, i)
            ELSE
              omega(l, i)=0.0_RealK
            ENDIF
            omega(l, i) &
              =min(omega(l, i), 1.0_RealK-3.2e+01_realk*eps_r)
          ENDDO
        ENDDO
!
      ELSE IF (i_scatter_method_band == IP_no_scatter_abs) THEN
!
!       The scattering extinction is ignored completely, so
!       only the absorptive contributions to the single
!       scattering properties are included. If full scattering
!       is not to be used in the IR this is normally the appropriate
!       approximation as scattering is still dominated by the
!       forward peak.
!
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            tau(l, i)=(k_grey_tot(l, i)+k_gas_abs(l, i) &
              -k_ext_scat(l, i))*d_mass(l, i)
            omega(l, i)=0.0
          ENDDO
        ENDDO
!
      ELSE IF (i_scatter_method_band == IP_no_scatter_ext) THEN
!
!       The scattering extinction is added on to the absorption.
!       This option is usually a bad approximation to the effects
!       of scattering in the IR, but may occasionally be appropriate
!       if the asymmetry is low.
!
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            tau(l, i)=(k_grey_tot(l, i)+k_gas_abs(l, i)) &
              *d_mass(l, i)
            omega(l, i)=0.0_RealK
          ENDDO
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE SINGLE_SCATTERING
!+ Subroutine to calculate the basic coefficients for the solar beam.
!
! Method:
!        Straightforward.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solar_coefficient_basic(ierr &
        , n_profile, i_layer_first, i_layer_last &
        , omega, asymmetry, sec_00 &
        , i_2stream &
        , sum, diff, lambda &
        , gamma_up, gamma_down &
        , nd_profile, id_lt, id_lb &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE two_stream_scheme_pcf
      USE def_std_io_icf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER &
          nd_profile &
!           Size allocated for atmospheric profiles
        , id_lt &
!           Topmost declared layer
        , id_lb
!           Bottom declared layer
!
!
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to consider
        , i_layer_last &
!           First layer to consider
        , i_2stream
!           Two-stream scheme
!
      REAL  (RealK), Intent(IN) :: &
          omega(nd_profile, id_lt: id_lb) &
!           Albedo of single scattering
        , asymmetry(nd_profile, id_lt: id_lb) &
!           Asymmetry
        , sec_00(nd_profile, id_lt: id_lb)
!           Secant of solar zenith angle
!
!     Basic two-stream coefficients:
      REAL  (RealK), Intent(INOUT) :: &
          sum(nd_profile, id_lt: id_lb) &
!           Sum of two-stream coefficients
        , diff(nd_profile, id_lt: id_lb) &
!           Difference of two-stream coefficients
        , lambda(nd_profile, id_lt: id_lb)
!           Lambda
      REAL  (RealK), Intent(OUT) :: &
          gamma_up(nd_profile, id_lt: id_lb) &
!           Coefficient for upward radiation
        , gamma_down(nd_profile, id_lt: id_lb)
!           Coefficient for downwad radiation
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          ksi_0(nd_profile, id_lt: id_lb) &
!           Difference in solar scattering fractions
        , factor
!           Temporary variable
      REAL  (RealK) :: &
          root_3
!           Square root of 3
      parameter( &
          root_3=1.7320508075688772e+00_RealK &
        )
!
!     Variables related to the treatment of ill-conditioning
      REAL  (RealK) :: &
          tol_perturb
!           The tolerance used to judge where the two-stream
!           expressions for the solar source become ill-conditioned
!
!
!
!     Set the tolerances used in avoiding ill-conditioning, testing
!     on any variable.
      tol_perturb=3.2e+01_RealK*epsilon(sec_00(1,1))
!
!     If LAMBDA is too close to SEC_0 it must be perturbed.
      DO i=id_lt, id_lb
        DO l=1, nd_profile
          IF ((abs(lambda(l, i)-sec_00(l, i))) < tol_perturb) THEN
            sum(l, i)=(1.0e+00_RealK+tol_perturb)*sum(l, i)
            diff(l, i)=(1.0e+00_RealK+tol_perturb)*diff(l, i)
            lambda(l, i)=(1.0e+00_RealK+tol_perturb)*lambda(l, i)
          ENDIF
        ENDDO
      ENDDO
!
      IF ( (i_2stream == IP_eddington).OR. &
           (i_2stream == IP_elsasser).OR. &
           (i_2stream == IP_pifm85).OR. &
           (i_2stream == IP_2s_test).OR. &
           (i_2stream == IP_hemi_mean).OR. &
           (i_2stream == IP_pifm80) ) THEN
!
!CDIR COLLAPSE
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            ksi_0(l, i)=1.5e+00_RealK*asymmetry(l, i)/sec_00(l, i)
          ENDDO
        ENDDO
!
      ELSE IF (i_2stream == IP_discrete_ord) THEN
!
!CDIR COLLAPSE
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            ksi_0(l, i)=root_3*asymmetry(l, i)/sec_00(l, i)
          ENDDO
        ENDDO
!
      ELSE
!
        WRITE(iu_err, '(/a)') &
          '*** Error: An illegal solar two-stream scheme has ' &
          //'been selected.'
        ierr=i_err_fatal
        RETURN
!
      ENDIF
!
!
!     Determine the basic solar coefficients for the
!     two-stream equations.
!
!CDIR COLLAPSE
      DO i=id_lt, id_lb
        DO l=1, nd_profile
          factor=0.5e+00_RealK*omega(l, i)*sec_00(l, i) &
            /((lambda(l, i)-sec_00(l, i))*(lambda(l, i)+sec_00(l, i)))
          gamma_up(l, i)=factor*(sum(l, i)-sec_00(l, i) &
            -ksi_0(l, i)*(diff(l, i)-sec_00(l, i)))
          gamma_down(l, i)=factor*(sum(l, i)+sec_00(l, i) &
            +ksi_0(l, i)*(diff(l, i)+sec_00(l, i)))
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLAR_COEFFICIENT_BASIC
!+ Subroutine to calculate the solar flux and source terms.
!
! Method:
!        Straightforward.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solar_source(n_profile, n_layer &
         , flux_inc_direct &
         , trans_0, source_coeff &
         , l_scale_solar, adjust_solar_ke &
         , flux_direct &
         , s_down, s_up &
         , nd_profile, nd_layer, nd_source_coeff &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE source_coeff_pointer_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_source_coeff
!           Size allocated for coefficients in the source terms
!
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
!
      LOGICAL, Intent(IN) :: &
          l_scale_solar
!           Scaling applied to solar beam
!
      REAL  (RealK), Intent(IN) :: &
          flux_inc_direct(nd_profile) &
!           Incident solar flux
        , trans_0(nd_profile, nd_layer) &
!           Direct transmission coefficient
        , source_coeff(nd_profile, nd_layer, nd_source_coeff) &
!           Reflection coefficient
        , adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment to solar flux
!
!
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Direct flux
        , s_down(nd_profile, nd_layer) &
!           Downward source function
        , s_up(nd_profile, nd_layer)
!           Upward source function
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!
!
      DO l=1, n_profile
        flux_direct(l, 0)=flux_inc_direct(l)
      ENDDO
!
!     The solar flux may be multiplied by a scaling factor if an
!     equivalent extinction is used.
!
      IF (l_scale_solar) THEN
!
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            flux_direct(l, i) &
              =flux_direct(l, i-1)*trans_0(l, i) &
              *adjust_solar_ke(l, i)
          ENDDO
        ENDDO
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            s_up(l, i)=source_coeff(l, i, IP_scf_solar_up) &
              *flux_direct(l, i-1)
            s_down(l, i)=(source_coeff(l, i, IP_scf_solar_down) &
              -trans_0(l, i))*flux_direct(l, i-1) &
              +flux_direct(l, i)
          ENDDO
        ENDDO
!
      ELSE
!
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            flux_direct(l, i) &
              =flux_direct(l, i-1)*trans_0(l, i)
          ENDDO
        ENDDO
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            s_up(l, i)=source_coeff(l, i, IP_scf_solar_up) &
              *flux_direct(l, i-1)
            s_down(l, i)=source_coeff(l, i, IP_scf_solar_down) &
              *flux_direct(l, i-1)
          ENDDO
        ENDDO
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE SOLAR_SOURCE
!+ Subroutine to calculate solar scattering angles.
!
! Purpose:
!   This routine returns the cosines of the angles of scattering
!   from the solar beam for each viewing direction.
!
! Method:
!   A scalar product of the solar and viewing directions is
!   evaluated. This routine is called only when radiances are to
!   be calculated, so ND_PROFILE can be used for all horizontal
!   dimensions.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE sol_scat_cos(n_profile, n_direction &
        , mu_0, direction, cos_sol_view &
        , nd_profile, nd_direction)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_direction
!           Size allocated for viewing directions
!
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of atmospheric profiles
        , n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          mu_0(nd_profile) &
!           Cosines of solar zenith angles
        , direction(nd_profile, nd_direction, 2)
!           Viewing directions stored as the cosine of the polar
!           viewing angle and the azimuthal viewing angle itself
!           realative to the solar direction
      REAL  (RealK), Intent(OUT) :: &
          cos_sol_view(nd_profile, nd_direction)
!           Cosines of the angles between the solar beam and the
!           viewing directions
!
!
!     Local variables
      INTEGER &
          id &
!           Loop variable
        , l
!           Loop variable
!
!
!
      DO id=1, n_direction
        DO l=1, n_profile
          cos_sol_view(l, id)=-mu_0(l)*direction(l, id, 1) &
            +sqrt((1.0e+00_RealK-mu_0(l)*mu_0(l)) &
            *(1.0e+00_RealK-direction(l, id, 1)*direction(l, id, 1))) &
            *cos(direction(l, id, 2))
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOL_SCAT_COS
!+ Subroutine to calculate fluxes using equivalent extinction.
!
! Method:
!        For each minor gas an equivalent extinction is calculated
!        from a clear-sky calculation. These equivalent extinctions
!        are then used in a full calculation involving the major gas.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solve_band_k_eqv(ierr &
!                        Atmospheric Properties
        , n_profile, n_layer, i_top, p, t, d_mass &
!                        Angular Integration
        , i_angular_integration, i_2stream &
        , n_order_phase, l_rescale, n_order_gauss &
        , ms_min, ms_max, i_truncation, ls_local_trunc &
        , accuracy_adaptive, euler_factor &
        , i_sph_algorithm, i_sph_mode &
!                     Precalculated angular arrays
        , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of Scattering
        , i_scatter_method &
!                        Options for Solver
        , i_solver &
!                        Gaseous Properties
        , i_band, n_gas &
        , index_absorb, i_band_esft, i_scale_esft, i_scale_fnc &
        , k_esft, w_esft, scale_vector &
        , p_reference, t_reference &
        , gas_mix_ratio, gas_frac_rescaled &
        , l_doppler, doppler_correction &
!                        Spectral Region
        , isolir &
!                        Solar Properties
        , zen_0, zen_00, solar_irrad & !hmjb
!                        Infra-red Properties
        , planck_flux_band &
        , diff_planck_band &
        , l_ir_source_quad, diff_planck_band_2 &
!                        Surface Properties
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
        , diff_albedo_basis &
        , planck_flux_surface &
!                       Tiling of the surface
        , l_tile, n_point_tile, n_tile, list_tile, rho_alb_tile &
        , planck_flux_tile &
!                        Optical Properties
        , ss_prop &
!                        Cloudy Properties
        , l_cloud, i_cloud &
!                        Cloud Geometry
        , n_cloud_top &
        , n_cloud_type, frac_cloud &
        , n_region, k_clr, i_region_cloud, frac_region &
        , w_free, w_cloud, cloud_overlap &
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
        , n_direction, direction &
!                       Weighting factor for the band
        , weight_band, l_initial &
!                        Fluxes Calculated
        , flux_direct, flux_down, flux_up &
!                       Radiances
        , i_direct, radiance &
!                        Rate of photolysis
        , photolysis &
!                        Flags for Clear-sky Fluxes
        , l_clear, i_solver_clear &
!                        Clear-sky Fluxes Calculated
        , flux_direct_clear, flux_down_clear, flux_up_clear &
!                       Tiled Surface Fluxes
        , flux_up_tile, flux_up_blue_tile &
!                       Special Surface Fluxes
        , l_blue_flux_surf, weight_blue &
        , flux_direct_blue_surf &
        , flux_down_blue_surf, flux_up_blue_surf &
!                        Dimensions of Arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_band, nd_species &
        , nd_esft_term, nd_scale_variable &
        , nd_cloud_type, nd_region, nd_overlap_coeff &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
        , nd_direction, nd_source_coeff &
        , nd_point_tile, nd_tile &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE angular_integration_pcf
      USE surface_spec_pcf
      USE spectral_region_pcf
      USE k_scale_pcf
      USE diff_keqv_ucf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , nd_layer_clr &
!           Size allowed for totally clear layers
        , id_ct &
!           Topmost declared cloudy level
        , nd_band &
!           Size allocated for spectral bands
        , nd_species &
!           Size allocated for species
        , nd_esft_term &
!           Size allocated for ESFT terms
        , nd_scale_variable &
!           Size allocated for scale variables
        , nd_flux_profile &
!           Size allocated for profiles in arrays of fluxes
        , nd_radiance_profile &
!           Size allocated for profiles in arrays of radiances
        , nd_j_profile &
!           Size allocated for profiles in arrays of mean radiances
        , nd_column &
!           Size allocated for sub-columns per point
        , nd_cloud_type &
!           Size allocated for cloud types
        , nd_region &
!           Size allocated for cloudy regions
        , nd_overlap_coeff &
!           Size allocated for cloudy overlap coefficients
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_sph_coeff &
!           Size allocated for spherical harmonic coefficients
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for orders of BRDFs
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_direction &
!           Size allocated for viewing directions
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_point_tile &
!           Size allocated for points where the surface is tiled
        , nd_tile
!           Size allocated for surface tiles
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!                        Atmospheric properties
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , i_top
!           Top of vertical grid
      REAL  (RealK), Intent(IN) :: &
          d_mass(nd_profile, nd_layer) &
!           Mass thickness of each layer
        , p(nd_profile, nd_layer) &
!           Pressure
        , t(nd_profile, nd_layer)
!           Temperature
!
!                        Angular integration
      INTEGER, Intent(IN) :: &
          i_angular_integration &
!           Angular integration scheme
        , i_2stream &
!           Two-stream scheme
        , n_order_phase &
!           Maximum order of terms in the phase function used in
!           the direct calculation of spherical harmonics
        , n_order_gauss &
!           Order of gaussian integration
        , ms_min &
!           Lowest azimuthal order used
        , ms_max &
!           Highest azimuthal order used
        , i_truncation &
!           Type of spherical truncation
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient of (m, m) for each m
        , ls_local_trunc(0: nd_max_order) &
!           Orders of truncation at each azimuthal order
        , i_sph_mode &
!           Mode in which the spherical solver runs
        , i_sph_algorithm
!           Algorithm used for spherical harmonic calculation
      LOGICAL, Intent(IN) :: &
          l_rescale
!           Rescale optical properties
      REAL  (RealK), Intent(IN) :: &
          weight_band
!           Weighting factor for the current band
      LOGICAL, Intent(INOUT) :: &
          l_initial
!           Flag to initialize diagnostics
!
      REAL  (RealK), Intent(IN) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-Gordan coefficients
        , uplm_zero(nd_sph_coeff) &
!           Values of spherical harmonics at polar angles pi/2
        , uplm_sol(nd_radiance_profile, nd_sph_coeff) &
!           Values of spherical harmonics in the solar direction
        , accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last term of an alternating series
!
!                        Treatment of scattering
      INTEGER, Intent(IN) :: &
          i_scatter_method
!           Method of treating scattering
!
!                        Options for solver
      INTEGER, Intent(IN) :: &
          i_solver
!           Solver used
!
!                        Gaseous properties
      INTEGER, Intent(IN) :: &
          i_band &
!           Band being considered
        , n_gas &
!           Number of gases in band
        , index_absorb(nd_species, nd_band) &
!           List of absorbers in bands
        , i_band_esft(nd_band, nd_species) &
!           Number of terms in band
        , i_scale_esft(nd_band, nd_species) &
!           Type of ESFT scaling
        , i_scale_fnc(nd_band, nd_species)
!           Type of scaling function
      LOGICAL, Intent(IN) :: &
          l_doppler(nd_species)
!           Doppler broadening included
      REAL  (RealK), Intent(IN) :: &
          k_esft(nd_esft_term, nd_band, nd_species) &
!           Exponential ESFT terms
        , w_esft(nd_esft_term, nd_band, nd_species) &
!           Weights for ESFT
        , scale_vector(nd_scale_variable, nd_esft_term, nd_band &
            , nd_species) &
!           Absorber scaling parameters
        , p_reference(nd_species, nd_band) &
!           Reference scaling pressure
        , t_reference(nd_species, nd_band) &
!           Reference scaling temperature
        , gas_mix_ratio(nd_profile, nd_layer, nd_species) &
!           Gas mass mixing ratios
        , doppler_correction(nd_species)
!           Doppler broadening terms
      REAL  (RealK), Intent(OUT) :: &
          gas_frac_rescaled(nd_profile, nd_layer, nd_species)
!           Rescaled gas mass fractions
!
!                        Spectral region
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
!
!                        Solar properties
      REAL  (RealK), Intent(IN) :: &
          zen_0(nd_profile) &
        , zen_00(nd_profile, nd_layer) & !hmjb
!           Secant (two-stream) or cosine (spherical harmonics)
!           of the solar zenith angle
        , solar_irrad(nd_profile)
!           Incident solar irradiance in band
!
!                        Infra-red properties
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source function
      REAL  (RealK), Intent(IN) :: &
          planck_flux_band(nd_profile, 0: nd_layer) &
!           Flux Planckian source in band
        , diff_planck_band(nd_profile, nd_layer) &
!           First differences in the flux Planckian across layers
!           in this band
        , diff_planck_band_2(nd_profile, nd_layer)
!           Twice 2nd differences in the flux Planckian in band
!
!                        Surface properties
      REAL  (RealK), Intent(IN) :: &
          planck_flux_surface(nd_profile)
!           Flux Planckian at the surface temperature
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of truncation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
        , diff_albedo_basis(nd_brdf_basis_fnc)
!           The diffuse albedo of each basis function
!
!     Variables related to tiling of the surface
      LOGICAL, Intent(IN) :: &
          l_tile
!           Logical to allow invoke options
      INTEGER, Intent(IN) :: &
          n_point_tile &
!           Number of points to tile
        , n_tile &
!           Number of tiles used
        , list_tile(nd_point_tile)
!           List of points with surface tiling
      REAL  (RealK), Intent(IN) :: &
          rho_alb_tile(nd_point_tile, nd_brdf_basis_fnc, nd_tile) &
!           Weights for the basis functions of the BRDFs
!           at the tiled points
        , planck_flux_tile(nd_point_tile, nd_tile)
!           Local Planckian fluxes on surface tiles
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!                        Cloudy properties
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Clouds required
      INTEGER, Intent(IN) :: &
          i_cloud
!           Cloud scheme used
!
!                        Cloud geometry
      INTEGER, Intent(IN) :: &
          n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_type &
!           Number of types of clouds
        , n_region &
!           Number of cloudy regions
        , k_clr &
!           Index of clear-sky region
        , i_region_cloud(nd_cloud_type)
!           Regions in which types of clouds fall
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy fraction
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of different types of cloud
        , w_free(nd_profile, id_ct: nd_layer) &
!           Clear-sky fraction
        , cloud_overlap(nd_profile, id_ct-1: nd_layer &
            , nd_overlap_coeff) &
!           Coefficients for transfer for energy at interfaces
        , area_column(nd_profile, nd_column) &
!           Areas of columns
        , frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fractions of total cloud occupied by each region
!
!
!                        Levels for calculating radiances
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2)
!           Viewing directions
!
!                        Calculated fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct flux in band
        , flux_down(nd_flux_profile, 0: nd_layer) &
!           Total downward flux
        , flux_up(nd_flux_profile, 0: nd_layer)
!           Upward flux
!
!                       Calculated radiances
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_radiance_profile, 0: nd_layer) &
!           Direct solar irradiance on levels
        , radiance(nd_radiance_profile, nd_viewing_level, nd_direction)
!           Radiances in the current band
!
!                       Calculated radiances
      REAL  (RealK), Intent(INOUT) :: &
          photolysis(nd_j_profile, nd_viewing_level)
!           Rate of photolysis in the current band
!
!                        Flags for clear-sky fluxes
      LOGICAL, Intent(IN) :: &
          l_clear
!           Calculate clear-sky properties
      INTEGER, Intent(IN) :: &
          i_solver_clear
!           Clear solver used
!
!                        Clear-sky fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky direct flux
        , flux_down_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky total downward flux
        , flux_up_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky total downward flux
        , flux_up_tile(nd_point_tile, nd_tile) &
!           Upward fluxes at tiled surface points
        , flux_up_blue_tile(nd_point_tile, nd_tile)
!           Upward blue fluxes at tiled surface points
!
!                        Special Diagnostics:
      LOGICAL, Intent(IN) :: &
          l_blue_flux_surf
!           Flag to calculate blue fluxes at the surface
      REAL  (RealK), Intent(IN) :: &
          weight_blue
!           Weights for blue fluxes in this band
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_blue_surf(nd_flux_profile) &
!           Direct downward blue flux at the surface
        , flux_down_blue_surf(nd_flux_profile) &
!           Total downward blue flux at the surface
        , flux_up_blue_surf(nd_flux_profile)
!           Upward blue flux at the surface
!
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l
!           Loop variable
      INTEGER &
          i_gas &
!           Index of main gas
        , i_gas_band &
!           Index of active gas
        , i_gas_pointer(nd_species) &
!           Pointer array for monochromatic ESFTs
        , iex
!           Index of ESFT term
      REAL  (RealK) :: &
          d_planck_flux_surface(nd_profile) &
!           Difference in Planckian fluxes between the surface
!           and the air
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , flux_inc_down(nd_profile) &
!           Incident downward flux
        , esft_weight &
!           ESFT weight for current calculation
        , adjust_solar_ke(nd_profile, nd_layer) &
!           Adjustment of solar transmission to `include'' effects
!           of minor gases and take out equivalent extinction
        , k_eqv(nd_profile, nd_layer) &
!           Equivalent extinction
        , tau_gas(nd_profile, nd_layer) &
!           Optical depth of gas
        , k_esft_mono(nd_species) &
!           Monochromatic exponents
        , k_gas_abs(nd_profile, nd_layer) &
!           Gaseous extinction
        , diffuse_albedo(nd_profile)
!           Diffuse albedo of the surface
      REAL  (RealK) :: &
          flux_direct_part(nd_flux_profile, 0: nd_layer) &
!           Partial direct flux
        , flux_total_part(nd_flux_profile, 2*nd_layer+2) &
!           Partial total flux
        , flux_direct_clear_part(nd_flux_profile, 0: nd_layer) &
!           Clear partial direct flux
        , flux_total_clear_part(nd_flux_profile, 2*nd_layer+2)
!           Clear partial total flux
      REAL  (RealK) :: &
          i_direct_part(nd_radiance_profile, 0: nd_layer) &
!           Partial solar irradiances
        , radiance_part(nd_radiance_profile, nd_viewing_level &
            , nd_direction)
!           Partial radiances
      REAL  (RealK) :: &
          photolysis_part(nd_j_profile, nd_viewing_level)
!           Partial rate of photolysis
      REAL  (RealK) :: &
          weight_incr &
!           Weight applied to increments
        , weight_blue_incr
!           Weight applied to blue increments
!
!     Fluxes used for equivalent extinction (we base the equivalent
!     extinction on fluxes, even when calculating radiances, so
!     full sizes are required for these arrays).
      REAL  (RealK) :: &
          sum_flux(nd_profile, 2*nd_layer+2, nd_species) &
!           Sum of fluxes for weighting
        , sum_k_flux(nd_profile, 2*nd_layer+2, nd_species) &
!           Sum of k*fluxes for weighting
        , flux_term(nd_profile, 2*nd_layer+2) &
!           Flux with one term
        , flux_gas(nd_profile, 0: nd_layer)
!           Flux with one gas
      REAL  (RealK) :: &
          mean_net_flux &
!           Mean net flux
        , mean_k_net_flux &
!           Mean k-weighted net flux
        , k_weak
!           Weak absorption for minor gas
      REAL  (RealK) :: &
          k_no_gas_tot_clr(nd_profile, nd_layer_clr) &
!           Stored clear-ksy contribution to extinction
!           with no gaseous contribution
        , k_no_gas_tot(nd_profile, id_ct: nd_layer, 0: nd_cloud_type)
!           Stored contribution to extinction
!           with no gaseous contribution
!
!     Subroutines called:
!      EXTERNAL &
!          scale_absorb, gas_optical_properties &
!        , monochromatic_gas_flux, monochromatic_radiance &
!        , augment_radiance
!
!
!
      i_gas=index_absorb(1, i_band)
!
      IF (isolir == IP_solar) THEN
!
!       An appropriate scaling factor is calculated for the direct
!       beam, whilst the equivalent extinction for the diffuse beam
!       is weighted with the solar scaling factor as evaluated
!       at the surface.
!
!       Initialize the scaling factors:
        DO i=1, n_layer
          DO l=1, n_profile
            adjust_solar_ke(l, i)=1.0e+00_RealK
            k_eqv(l, i)=0.0e+00_RealK
          ENDDO
        ENDDO
!
        DO j=2, n_gas
!
!         Initialize the normalized flux for the gas.
          DO l=1, n_profile
            flux_gas(l, 0)=1.0e+00_RealK
            sum_k_flux(l, n_layer, j)=0.0e+00_RealK
            sum_flux(l, n_layer, j)=0.0e+00_RealK
          ENDDO
          DO i=1, n_layer
            DO l=1, n_profile
              flux_gas(l, i)=0.0e+00_RealK
            ENDDO
          ENDDO
!
          i_gas_band=index_absorb(j, i_band)
          DO iex=1, i_band_esft(i_band, i_gas_band)
!
!           Store the ESFT weight for future use.
            esft_weight=w_esft(iex, i_band,  i_gas_band)
!
!           Rescale the amount of gas for this absorber if required.
            IF (i_scale_esft(i_band, i_gas_band) == IP_scale_term) THEN
              CALL scale_absorb(ierr, n_profile, n_layer &
                , gas_mix_ratio(1, 1, i_gas_band), p, t &
                , i_top &
                , gas_frac_rescaled(1, 1, i_gas_band) &
                , i_scale_fnc(i_band, i_gas_band) &
                , p_reference(i_gas_band, i_band) &
                , t_reference(i_gas_band, i_band) &
                , scale_vector(1, iex, i_band, i_gas_band) &
                , l_doppler(i_gas_band) &
                , doppler_correction(i_gas_band) &
                , nd_profile, nd_layer &
                , nd_scale_variable &
                )
              IF (ierr /= i_normal) RETURN
            ENDIF
!
!           For use in the infra-red case FLUX_TERM is defined to start
!           at 1, so for this array only the flux at level I appears
!           as the I+1st element.
            DO l=1, n_profile
              flux_term(l, 1)=esft_weight
            ENDDO
!           Because the contents of ZEN_0 depend on the mode of
!           angular integration we need two different loops.
            IF (i_angular_integration == IP_two_stream) THEN
              DO i=1, n_layer
                DO l=1, n_profile
                  flux_term(l, i+1)=flux_term(l, i) &
                    *exp(-k_esft(iex, i_band, i_gas_band) &
                    *gas_frac_rescaled(l, i, i_gas_band) &
                    *d_mass(l, i)*zen_00(l, i))
                  flux_gas(l, i)=flux_gas(l, i)+flux_term(l, i+1)
                ENDDO
              ENDDO
            ELSE IF (i_angular_integration == IP_spherical_harmonic) &
                THEN
              DO i=1, n_layer
                DO l=1, n_profile
                  flux_term(l, i+1)=flux_term(l, i) &
                    *exp(-k_esft(iex, i_band, i_gas_band) &
                    *gas_frac_rescaled(l, i, i_gas_band) &
                    *d_mass(l, i)/zen_00(l, i))
                  flux_gas(l, i)=flux_gas(l, i)+flux_term(l, i+1)
                ENDDO
              ENDDO
            ENDIF
!
!           Calculate the increment in the absorptive extinction
            DO l=1, n_profile
              sum_k_flux(l, n_layer, j) &
                =sum_k_flux(l, n_layer, j) &
                +k_esft(iex, i_band, i_gas_band) &
                *flux_term(l, n_layer+1)
              sum_flux(l, n_layer, j) &
                =sum_flux(l, n_layer, j)+flux_term(l, n_layer+1)
            ENDDO
!
          ENDDO
!
!         Set the equivalent extinction for the diffuse beam,
!         weighting with the direct surface flux.
          DO i=1, n_layer
            DO l=1, n_profile
              k_eqv(l, i)=k_eqv(l, i) &
                +gas_frac_rescaled(l, i, i_gas_band) &
                *sum_k_flux(l, n_layer, j) &
                /sum_flux(l, n_layer, j)
              adjust_solar_ke(l, i) &
                =adjust_solar_ke(l, i)*flux_gas(l, i) &
                /flux_gas(l, i-1)
            ENDDO
          ENDDO
!
        ENDDO
!
!       Since the grey extinction will later be modified we must
!       increase the transmission of the solar beam to compensate.
        IF (i_angular_integration == IP_two_stream) THEN
          DO i=1, n_layer
            DO l=1, n_profile
              adjust_solar_ke(l, i)=adjust_solar_ke(l, i) &
                *exp(k_eqv(l, i)*d_mass(l, i)*zen_00(l, i))
            ENDDO
          ENDDO
        ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
          DO i=1, n_layer
            DO l=1, n_profile
              adjust_solar_ke(l, i)=adjust_solar_ke(l, i) &
                *exp(k_eqv(l, i)*d_mass(l, i)/zen_00(l, i))
            ENDDO
          ENDDO
        ENDIF
!
      ELSE IF (isolir == IP_infra_red) THEN
!
!       Calculate the diffuse albedo of the surface.
        IF (i_angular_integration == IP_two_stream) THEN
          DO l=1, n_profile
            diffuse_albedo(l)=rho_alb(l, IP_surf_alb_diff)
          ENDDO
        ELSE IF (i_angular_integration == IP_ir_gauss) THEN
!         Only a non-reflecting surface is consistent with this
!         option.
          DO l=1, n_profile
            diffuse_albedo(l)=0.0e+00_RealK
          ENDDO
        ELSE IF (i_angular_integration == &
          IP_spherical_harmonic) THEN
          DO l=1, n_profile
            diffuse_albedo(l)=rho_alb(l, 1)*diff_albedo_basis(1)
          ENDDO
          DO j=1, n_brdf_basis_fnc
            DO l=1, n_profile
              diffuse_albedo(l)=rho_alb(l, j)*diff_albedo_basis(j)
            ENDDO
          ENDDO
        ENDIF
!
!       Equivalent absorption is used for the minor gases.
!
        DO j=2, n_gas
!
!
!         Initialize the sums to form the ratio to 0.
          DO i=1, 2*n_layer+2
            DO l=1, n_profile
              sum_flux(l, i, j)=0.0e+00_RealK
              sum_k_flux(l, i, j)=0.0e+00_RealK
            ENDDO
          ENDDO
!
          i_gas_band=index_absorb(j, i_band)
          DO iex=1, i_band_esft(i_band, i_gas_band)
!
!           Store the ESFT weight for future use.
            esft_weight=w_esft(iex, i_band,  i_gas_band)
!
!
!           Rescale the amount of gas for this absorber if required.
            IF (i_scale_esft(i_band, i_gas_band) == IP_scale_term) &
                  THEN
              CALL scale_absorb(ierr, n_profile, n_layer &
                , gas_mix_ratio(1, 1, i_gas_band), p, t &
                , i_top &
                , gas_frac_rescaled(1, 1, i_gas_band) &
                , i_scale_fnc(i_band, i_gas_band) &
                , p_reference(i_gas_band, i_band) &
                , t_reference(i_gas_band, i_band) &
                , scale_vector(1, iex, i_band, i_gas_band) &
                , l_doppler(i_gas_band) &
                , doppler_correction(i_gas_band) &
                , nd_profile, nd_layer &
                , nd_scale_variable &
                )
              IF (ierr /= i_normal) RETURN
            ENDIF
!
!           Set the appropriate boundary terms for the
!           total upward and downward fluxes at the boundaries.
!
            DO l=1, n_profile
              flux_inc_direct(l)=0.0e+00_RealK
              flux_inc_down(l)=-planck_flux_band(l, 0)
              d_planck_flux_surface(l)=planck_flux_surface(l) &
                -planck_flux_band(l, n_layer)
            ENDDO
!
!           Set the optical depths of each layer.
            DO i=1, n_layer
              DO l=1, n_profile
                tau_gas(l, i)=k_esft(iex, i_band, i_gas_band) &
                  *gas_frac_rescaled(l, i, i_gas_band) &
                  *d_mass(l, i)
              ENDDO
            ENDDO
!
!           Calculate the fluxes with just this gas. FLUX_TERM is
!           passed to both the direct and total fluxes as we do
!           not calculate any direct flux here.
            CALL monochromatic_gas_flux(n_profile, n_layer &
              , tau_gas &
              , isolir, zen_0, flux_inc_direct, flux_inc_down &
              , diff_planck_band, d_planck_flux_surface &
              , diffuse_albedo, diffuse_albedo &
              , diffusivity_factor_minor &
              , flux_term, flux_term &
              , nd_profile, nd_layer &
              )
!
            DO i=1, 2*n_layer+2
              DO l=1, n_profile
                sum_k_flux(l, i, j)=sum_k_flux(l, i, j) &
                  +k_esft(iex, i_band, i_gas_band) &
                  *esft_weight*flux_term(l, i)
                sum_flux(l, i, j)=sum_flux(l, i, j) &
                  +esft_weight*flux_term(l, i)
              ENDDO
            ENDDO
!
          ENDDO
!
        ENDDO
!
!
        DO i=1, n_layer
          DO l=1, n_profile
            k_eqv(l, i)=0.0e+00_RealK
          ENDDO
        ENDDO
!
        DO j=2, n_gas
          DO i=1, n_layer
            DO l=1, n_profile
              mean_k_net_flux=0.5e+00_RealK*(sum_k_flux(l, 2*i, j) &
                +sum_k_flux(l, 2*i+2, j) &
                -sum_k_flux(l, 2*i-1, j) &
                -sum_k_flux(l, 2*i+1, j))
              mean_net_flux=0.5e+00_RealK*(sum_flux(l, 2*i, j) &
                +sum_flux(l, 2*i+2, j) &
                -sum_flux(l, 2*i-1, j) &
                -sum_flux(l, 2*i+1, j))
!             Negative effective extinctions  are very unlikely
!             to arise, but must be removed.
              k_weak=max(0.0e+00_RealK, mean_k_net_flux/mean_net_flux)
              k_eqv(l, i)=k_eqv(l, i)+k_weak &
                *gas_frac_rescaled(l, i, index_absorb(j, i_band))
            ENDDO
          ENDDO
        ENDDO
      ENDIF
!
!
!     The ESFT terms for the major gas in the band are used with
!     appropriate weighted terms for the minor gases.
      i_gas_pointer(1)=i_gas
      DO iex=1, i_band_esft(i_band, i_gas)
!
!       Store the ESFT weight for future use.
        esft_weight=w_esft(iex, i_band,  i_gas)
!
!       Rescale for each ESFT term if that is required.
        IF (i_scale_esft(i_band, i_gas) == IP_scale_term) THEN
          CALL scale_absorb(ierr, n_profile, n_layer &
            , gas_mix_ratio(1, 1, i_gas), p, t &
            , i_top &
            , gas_frac_rescaled(1, 1, i_gas) &
            , i_scale_fnc(i_band, i_gas) &
            , p_reference(i_gas, i_band) &
            , t_reference(i_gas, i_band) &
            , scale_vector(1, iex, i_band, i_gas) &
            , l_doppler(i_gas), doppler_correction(i_gas) &
            , nd_profile, nd_layer &
            , nd_scale_variable &
            )
          IF (ierr /= i_normal) RETURN
        ENDIF
!
!       Set the appropriate boundary terms for the total
!       upward and downward fluxes.
!
        IF ( (i_angular_integration == IP_two_stream).OR. &
             (i_angular_integration == IP_ir_gauss) ) THEN
!
          IF (isolir == IP_solar) THEN
!           Solar region.
            DO l=1, n_profile
              d_planck_flux_surface(l)=0.0e+00_RealK
              flux_inc_down(l)=solar_irrad(l)/zen_0(l)
              flux_inc_direct(l)=solar_irrad(l)/zen_0(l)
            ENDDO
          ELSEIF (isolir == IP_infra_red) THEN
!           Infra-red region.
            DO l=1, n_profile
              flux_inc_direct(l)=0.0e+00_RealK
              flux_direct_part(l, n_layer)=0.0e+00_RealK
              flux_inc_down(l)=-planck_flux_band(l, 0)
              d_planck_flux_surface(l) &
                =planck_flux_surface(l) &
                -planck_flux_band(l, n_layer)
            ENDDO
            IF (l_clear) THEN
              DO l=1, n_profile
                flux_direct_clear_part(l, n_layer)=0.0e+00_RealK
              ENDDO
            ENDIF
          ENDIF
!
        ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
          IF (isolir == IP_solar) THEN
            DO l=1, n_profile
              i_direct_part(l, 0)=solar_irrad(l)
              flux_inc_down(l)=0.0e+00_RealK
            ENDDO
          ELSE
            DO l=1, n_profile
              flux_inc_down(l)=-planck_flux_band(l, 0)
              d_planck_flux_surface(l) &
                =planck_flux_surface(l)-planck_flux_band(l, n_layer)
            ENDDO
          ENDIF
!
        ENDIF
!
!
!       Augment the grey extinction with an effective value
!       for each gas. To enable the passing of a single structure,
!       we store the non-gaseous contributions and then restore
!       the original values.
!
        DO i=1, n_cloud_top-1
          DO l=1, n_profile
            k_no_gas_tot_clr(l, i)=ss_prop%k_grey_tot_clr(l, i)
            ss_prop%k_grey_tot_clr(l, i)=ss_prop%k_grey_tot_clr(l, i) &
              +k_eqv(l, i)
          ENDDO
        ENDDO
        DO i=n_cloud_top, n_layer
          DO l=1, n_profile
            k_no_gas_tot(l, i, 0)=ss_prop%k_grey_tot(l, i, 0)
            ss_prop%k_grey_tot(l, i, 0)=ss_prop%k_grey_tot(l, i, 0) &
              +k_eqv(l, i)
          ENDDO
        ENDDO
        IF (l_cloud) THEN
          DO k=1, n_cloud_type
            DO i=n_cloud_top, n_layer
              DO l=1, n_profile
                k_no_gas_tot(l, i, k)=ss_prop%k_grey_tot(l, i, k)
                ss_prop%k_grey_tot(l, i, k) &
                  =ss_prop%k_grey_tot(l, i, k)+k_eqv(l, i)
              ENDDO
            ENDDO
          ENDDO
        ENDIF
!
!       Assign the monochromatic absorption coefficient.
        k_esft_mono(i_gas)=k_esft(iex, i_band, i_gas)
!
        CALL gas_optical_properties(n_profile, n_layer &
          , 1, i_gas_pointer, k_esft_mono &
          , gas_frac_rescaled &
          , k_gas_abs &
          , nd_profile, nd_layer, nd_species &
          )
!
!
        CALL monochromatic_radiance(ierr &
!                        Atmospheric properties
          , n_profile, n_layer, d_mass &
!                        Angular integration
          , i_angular_integration, i_2stream &
          , l_rescale, n_order_gauss &
          , n_order_phase, ms_min, ms_max, i_truncation, ls_local_trunc &
          , accuracy_adaptive, euler_factor &
          , i_sph_algorithm, i_sph_mode &
!                       Precalculated angular arrays
          , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
          , i_scatter_method &
!                        Options for solver
          , i_solver &
!                        Gaseous propreties
          , k_gas_abs &
!                        Options for equivalent extinction
          , .true., adjust_solar_ke &
!                        Spectral region
          , isolir &
!                        Infra-red properties
          , diff_planck_band &
          , l_ir_source_quad, diff_planck_band_2 &
!                        Conditions at TOA
          , zen_0, zen_00, flux_inc_direct, flux_inc_down & !hmjb
          , i_direct_part &
!                        Surface properties
          , d_planck_flux_surface &
          , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
          , f_brdf, brdf_sol, brdf_hemi &
!                        Optical properties
          , ss_prop &
!                        Cloudy properties
          , l_cloud, i_cloud &
!                        Cloud geometry
          , n_cloud_top &
          , n_cloud_type, frac_cloud &
          , n_region, k_clr, i_region_cloud, frac_region &
          , w_free, w_cloud, cloud_overlap &
          , n_column_slv, list_column_slv &
          , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for the calculation of radiances
          , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
          , n_direction, direction &
!                       Calculated fluxes
          , flux_direct_part, flux_total_part &
!                       Calculated radiances
          , radiance_part &
!                       Calculated rate of photolysis
          , photolysis_part &
!                        Flags for clear-sky calculations
          , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
          , flux_direct_clear_part, flux_total_clear_part &
!                        Planckian function
          , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_cloud_type, nd_region, nd_overlap_coeff &
          , nd_max_order, nd_sph_coeff &
          , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
          , nd_direction, nd_source_coeff &
          )
        IF (ierr /= i_normal) RETURN
!
!       Restore the original optical properties.
        DO i=1, n_cloud_top-1
          DO l=1, n_profile
            ss_prop%k_grey_tot_clr(l, i)=k_no_gas_tot_clr(l, i)
          ENDDO
        ENDDO
        DO i=n_cloud_top, n_layer
          DO l=1, n_profile
            ss_prop%k_grey_tot(l, i, 0)=k_no_gas_tot(l, i, 0)
          ENDDO
        ENDDO
        IF (l_cloud) THEN
          DO k=1, n_cloud_type
            DO i=n_cloud_top, n_layer
              DO l=1, n_profile
                ss_prop%k_grey_tot(l, i, k)=k_no_gas_tot(l, i, k)
              ENDDO
            ENDDO
          ENDDO
        ENDIF
!
!       Increment the fluxes within the band.
        weight_incr=weight_band*esft_weight
        IF (l_blue_flux_surf) &
          weight_blue_incr=weight_blue*esft_weight
!
        CALL augment_radiance(n_profile, n_layer &
          , i_angular_integration, i_sph_mode &
          , n_viewing_level, n_direction &
          , isolir, l_clear, l_initial, weight_incr &
          , l_blue_flux_surf, weight_blue_incr &
!                        Actual Radiances
          , flux_direct, flux_down, flux_up &
          , flux_direct_blue_surf &
          , flux_down_blue_surf, flux_up_blue_surf &
          , i_direct, radiance, photolysis &
          , flux_direct_clear, flux_down_clear, flux_up_clear &
!                       Increments to radiances
          , flux_direct_part, flux_total_part &
          , i_direct_part, radiance_part, photolysis_part &
          , flux_direct_clear_part, flux_total_clear_part &
!                       Dimensions
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_layer, nd_viewing_level, nd_direction &
          )
!
!       Add in the increments from surface tiles
        IF (l_tile) THEN
          CALL augment_tiled_radiance(ierr &
            , n_point_tile, n_tile, list_tile &
            , i_angular_integration, isolir, l_initial &
            , weight_incr, l_blue_flux_surf, weight_blue_incr &
!                       Surface characteristics
            , rho_alb_tile &
!                       Actual radiances
            , flux_up_tile, flux_up_blue_tile &
!                       Increments to radiances
            , flux_direct_part(1, n_layer) &
            , flux_total_part(1, 2*n_layer+2) &
            , planck_flux_tile, planck_flux_band(1, n_layer) &
!                       Dimensions
            , nd_flux_profile, nd_point_tile, nd_tile &
            , nd_brdf_basis_fnc &
            )
          IF (ierr /= i_normal) RETURN
        ENDIF
!
!       After the first call to these routines quantities should be
!       incremented rather than initialized, until the flag is reset.
        l_initial=.false.
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLVE_BAND_K_EQV
!+ Subroutine to calculate the fluxes within the band with one gas.
!
! Method:
!        Monochromatic calculations are performed for each ESFT term
!        and the results are summed.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solve_band_one_gas(ierr &
!                        Atmospheric Column
        , n_profile, n_layer, i_top, p, t, d_mass &
!                        Angular Integration
        , i_angular_integration, i_2stream &
        , n_order_phase, l_rescale, n_order_gauss &
        , ms_min, ms_max, i_truncation, ls_local_trunc &
        , accuracy_adaptive, euler_factor &
        , i_sph_algorithm, i_sph_mode &
!                     Precalculated angular arrays
        , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of Scattering
        , i_scatter_method &
!                        Options for Solver
        , i_solver &
!                        Gaseous Properties
        , i_band, i_gas &
        , i_band_esft, i_scale_esft, i_scale_fnc &
        , k_esft, w_esft, scale_vector &
        , p_reference, t_reference &
        , gas_mix_ratio, gas_frac_rescaled &
        , l_doppler, doppler_correction &
!                        Spectral Region
        , isolir &
!                        Solar Properties
        , zen_0, zen_00, solar_irrad & !hmjb
!                        Infra-red Properties
        , planck_flux_top, planck_flux_bottom &
        , diff_planck_band &
        , l_ir_source_quad, diff_planck_band_2 &
!                        Surface Properties
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
        , planck_flux_ground &
!                       Tiling of the surface
        , l_tile, n_point_tile, n_tile, list_tile, rho_alb_tile &
        , planck_flux_tile &
!                        Optical Properties
        , ss_prop &
!                        Cloudy Properties
        , l_cloud, i_cloud &
!                        Cloud Geometry
        , n_cloud_top &
        , n_cloud_type, frac_cloud &
        , n_region, k_clr, i_region_cloud, frac_region &
        , w_free, w_cloud, cloud_overlap &
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
        , n_direction, direction &
!                       Weighting factor for the band
        , weight_band, l_initial &
!                        Calculated Fluxes
        , flux_direct, flux_down, flux_up &
!                       Calculated radiances
        , i_direct, radiance &
!                       Calculated rate of photolysis
        , photolysis &
!                        Flags for Clear-sky Fluxes
        , l_clear, i_solver_clear &
!                        Clear-sky Fluxes
        , flux_direct_clear, flux_down_clear, flux_up_clear &
!                       Tiled Surface Fluxes
        , flux_up_tile, flux_up_blue_tile &
!                       Special Surface Fluxes
        , l_blue_flux_surf, weight_blue &
        , flux_direct_blue_surf &
        , flux_down_blue_surf, flux_up_blue_surf &
!                        Dimensions of Arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_band, nd_species &
        , nd_esft_term, nd_scale_variable &
        , nd_cloud_type, nd_region, nd_overlap_coeff &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
        , nd_direction, nd_source_coeff &
        , nd_point_tile, nd_tile &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE spectral_region_pcf
      USE surface_spec_pcf
      USE angular_integration_pcf
      USE k_scale_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , nd_layer_clr &
!           Size allocated for totally clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_flux_profile &
!           Size allocated for profiles in arrays of fluxes
        , nd_radiance_profile &
!           Size allocated for profiles in arrays of radiances
        , nd_j_profile &
!           Size allocated for profiles in arrays of mean radiances
        , nd_column &
!           Size allocated for sub-columns per point
        , nd_band &
!           Size allocated for bands
        , nd_species &
!           Size allocated for species
        , nd_esft_term &
!           Size allocated for ESFT variables
        , nd_scale_variable &
!           Size allocated for scaling variables
        , nd_cloud_type &
!           Size allocated for cloud types
        , nd_region &
!           Size allocated for cloudy regions
        , nd_overlap_coeff &
!           Size allocated for cloudy overlap coefficients
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_sph_coeff &
!           Size allocated for coefficients of spherical harmonics
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for orders of BRDFs
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_direction &
!           Size allocated for viewing directions
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_point_tile &
!           Size allocated for points where the surface is tiled
        , nd_tile
!           Size allocated for surface tiles
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!                        Atmospheric column
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , i_top
!           Top of vertical grid
      REAL  (RealK), Intent(IN) :: &
          p(nd_profile, nd_layer) &
!           Pressure
        , t(nd_profile, nd_layer) &
!           Temperature
        , d_mass(nd_profile, nd_layer)
!           Mass thickness of each layer
!
!                        Angular integration
      INTEGER, Intent(IN) :: &
          i_angular_integration &
!           Angular integration scheme
        , i_2stream &
!           Two-stream scheme
        , n_order_phase &
!           Maximum order of terms in the phase function used in
!           the direct calculation of spherical harmonics
        , n_order_gauss &
!           Order of gaussian integration
        , ms_min &
!           Lowest azimuthal order used
        , ms_max &
!           Highest azimuthal order used
        , i_truncation &
!           Type of truncation used
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient of (m, m) for each m
        , ls_local_trunc(0: nd_max_order) &
!           Orders of truncation at each azimuthal order
        , i_sph_mode &
!           Mode in which the spherical harmonic code is used
        , i_sph_algorithm
!           Algorithm used for spherical harmonic calculation
      LOGICAL, Intent(IN) :: &
          l_rescale
!           Rescale optical properties
      REAL  (RealK) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-Gordan coefficients
        , uplm_zero(nd_sph_coeff) &
!           Values of spherical harmonics at polar angles pi/2
        , uplm_sol(nd_radiance_profile, nd_sph_coeff) &
!           Values of spherical harmonics in the solar direction
        , accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last term of an alternating series
      REAL  (RealK), Intent(IN) :: &
          weight_band
!           Weighting factor for the current band
      LOGICAL, Intent(INOUT) :: &
          l_initial
!           Flag to initialize diagnostics
!
!                        Treatment of scattering
      INTEGER, Intent(IN) :: &
          i_scatter_method
!           Method of treating scattering
!
!                        Options for solver
      INTEGER, Intent(IN) :: &
          i_solver
!           Solver used
!
!                        Gaseous properties
      INTEGER, Intent(IN) :: &
          i_band &
!           Band being considered
        , i_gas &
!           Gas being considered
        , i_band_esft(nd_band, nd_species) &
!           Number of terms in band
        , i_scale_esft(nd_band, nd_species) &
!           Type of ESFT scaling
        , i_scale_fnc(nd_band, nd_species)
!           Type of scaling function
      LOGICAL, Intent(IN) :: &
          l_doppler(nd_species)
!           Doppler broadening included
      REAL  (RealK), Intent(IN) :: &
          k_esft(nd_esft_term, nd_band, nd_species) &
!           Exponential ESFT terms
        , w_esft(nd_esft_term, nd_band, nd_species) &
!           Weights for ESFT
        , scale_vector(nd_scale_variable, nd_esft_term, nd_band &
            , nd_species) &
!           Absorber scaling parameters
        , p_reference(nd_species, nd_band) &
!           Reference scaling pressure
        , t_reference(nd_species, nd_band) &
!           Reference scaling temperature
        , gas_mix_ratio(nd_profile, nd_layer, nd_species) &
!           Gas mass mixing ratios
        , doppler_correction(nd_species)
!           Doppler broadening terms
      REAL  (RealK), Intent(INOUT) :: &
          gas_frac_rescaled(nd_profile, nd_layer, nd_species)
!           Rescaled gas mass fractions
!
!                        Spectral region
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
!
!                        Solar properties
      REAL  (RealK), Intent(IN) :: &
           zen_0(nd_profile) &
        ,  zen_00(nd_profile, nd_layer) & !hmjb
!           Secant (two-stream) or cosine (spherical harmonics)
!           of the solar zenith angle
        , solar_irrad(nd_profile)
!           Incident solar irradiance in band
!
!                        Infra-red properties
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source function
      REAL  (RealK), Intent(IN) :: &
          planck_flux_top(nd_profile) &
!           Planckian flux at the top of the layer
        , planck_flux_bottom(nd_profile) &
!           Planckian source at the bottom of the layer
        , diff_planck_band(nd_profile, nd_layer) &
!           Thermal source function
        , diff_planck_band_2(nd_profile, nd_layer)
!           Twice second difference of Planckian in band
!
!                        Surface properties
      REAL  (RealK), Intent(IN) :: &
          planck_flux_ground(nd_profile)
!           Thermal source function at ground
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of truncation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!     Variables related to tiling of the surface
      LOGICAL, Intent(IN) :: &
          l_tile
!           Logical to allow invoke options
      INTEGER, Intent(IN) :: &
          n_point_tile &
!           Number of points to tile
        , n_tile &
!           Number of tiles used
        , list_tile(nd_point_tile)
!           List of points with surface tiling
      REAL  (RealK), Intent(IN) :: &
          rho_alb_tile(nd_point_tile, nd_brdf_basis_fnc, nd_tile) &
!           Weights for the basis functions of the BRDFs
!           at the tiled points
        , planck_flux_tile(nd_point_tile, nd_tile)
!           Local Planckian fluxes on surface tiles
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!                        Cloudy properties
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Clouds required
      INTEGER, Intent(IN) :: &
          i_cloud
!           Cloud scheme used
!
!                        Cloud geometry
      INTEGER, Intent(IN) :: &
          n_cloud_top &
!           Top cloudy layer
        , n_cloud_type &
!           Number of types of clouds
        , n_region &
!           Number of cloudy regions
        , k_clr &
!           Index of clear-sky region
        , i_region_cloud(nd_cloud_type)
!           Regions in which types of clouds fall
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
          w_free(nd_profile, id_ct: nd_layer) &
!           Clear-sky fraction
        , w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy fraction
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of types of clouds
        , cloud_overlap(nd_profile, id_ct-1: nd_layer, nd_overlap_coeff) &
!           Coefficients for transfer for energy at interfaces
        , area_column(nd_profile, nd_column) &
!           Areas of columns
        , frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fractions of total cloud occupied by each region
!
!**o+
!*!                        cloudy optical properties
!*      real  (realk), intent(in) ::
!*     &    k_grey_tot_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!*!           cloudy absorptive extinction
!*     &  , k_ext_scat_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!*!           cloudy scattering extinction
!*     &  , phase_fnc_cloud(nd_profile, id_ct: nd_layer, nd_max_order
!*     &      , nd_cloud_type)
!*!           cloudy phase function
!*     &  , forward_scatter_cloud(nd_profile, id_ct: nd_layer
!*     &      , nd_cloud_type)
!*!           cloudy forward scattering
!*     &  , phase_fnc_solar_cloud(nd_radiance_profile, id_ct: nd_layer
!*     &      , nd_direction, nd_cloud_type)
!*!           cloudy phase function for the solar beam in viewing
!*!           directions
!**o-
!
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2)
!           Viewing directions
!
!                        Calculated fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct flux
        , flux_down(nd_flux_profile, 0: nd_layer) &
!           Total downward flux
        , flux_up(nd_flux_profile, 0: nd_layer)
!           Upward flux
!
!                       Calculated radiances
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_radiance_profile, 0: nd_layer) &
!           Direct solar irradiance on levels
        , radiance(nd_radiance_profile,  nd_viewing_level &
            , nd_direction)
!           Radiances
!
!                       Calculated mean radiances
      REAL  (RealK), Intent(INOUT) :: &
          photolysis(nd_j_profile,  nd_viewing_level)
!           Mean rate of photolysis
!
!                        Flags for clear-sky calculations
      LOGICAL, Intent(IN) :: &
          l_clear
!           Calculate net clear-sky properties
      INTEGER, Intent(IN) :: &
          i_solver_clear
!           Clear solver used
!
!                        Clear-sky fluxes calculated
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_clear(nd_profile, 0: nd_layer) &
!           Clear-sky direct flux
        , flux_down_clear(nd_profile, 0: nd_layer) &
!           Clear-sky total downward flux
        , flux_up_clear(nd_profile, 0: nd_layer) &
!           Clear-sky upward flux
        , flux_up_tile(nd_point_tile, nd_tile) &
!           Upward fluxes at tiled surface points
        , flux_up_blue_tile(nd_point_tile, nd_tile)
!           Upward blue fluxes at tiled surface points
!
!                        Special Diagnostics:
      LOGICAL, Intent(IN) :: &
          l_blue_flux_surf
!           Flag to calculate the blue flux at the surface
      REAL  (RealK), Intent(IN) :: &
          weight_blue
!           Weights for blue fluxes in this band
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_blue_surf(nd_flux_profile) &
!           Direct blue flux at the surface
        , flux_down_blue_surf(nd_flux_profile) &
!           Total downward blue flux at the surface
        , flux_up_blue_surf(nd_flux_profile)
!           Upward blue flux at the surface
!
!
!
!     Local variables.
      INTEGER &
          l
!           Loop variable
      INTEGER &
          i_gas_pointer(nd_species) &
!           Pointer array for monochromatic ESFTs
        , iex
!           Index of ESFT term
      REAL  (RealK) :: &
          k_esft_mono(nd_species) &
!           ESFT monochromatic exponents
        , k_gas_abs(nd_profile, nd_layer) &
!           Gaseous absorptive extinction
        , d_planck_flux_surface(nd_profile) &
!           Ground source function
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , flux_inc_down(nd_profile) &
!           Incident downward flux
        , dummy_ke(nd_profile, nd_layer)
!           Dummy array (not used)
!
!     Monochromatic incrementing radiances:
      REAL  (RealK) :: &
          flux_direct_part(nd_profile, 0: nd_layer) &
!           Partial direct flux
        , flux_total_part(nd_profile, 2*nd_layer+2) &
!           Partial total flux
        , flux_direct_clear_part(nd_profile, 0: nd_layer) &
!           Partial clear-sky direct flux
        , flux_total_clear_part(nd_profile, 2*nd_layer+2)
!           Partial clear-sky total flux
      REAL  (RealK) :: &
          i_direct_part(nd_radiance_profile, 0: nd_layer) &
!           Partial solar irradiances
        , radiance_part(nd_radiance_profile, nd_viewing_level &
            , nd_direction)
!           Partial radiances
      REAL  (RealK) :: &
          photolysis_part(nd_j_profile, nd_viewing_level)
!           Partial rate of photolysis
      REAL  (RealK) :: &
          weight_incr &
!           Weight applied to increments
        , weight_blue_incr
!           Weight applied to blue increments
!
!     Subroutines called:
!      EXTERNAL &
!          scale_absorb, gas_optical_properties &
!        , monochromatic_radiance, augment_radiance
!
!
!
!     The ESFT terms for the first gas in the band alone are used.
      i_gas_pointer(1)=i_gas
      DO iex=1, i_band_esft(i_band, i_gas)
!
!       Rescale for each ESFT term if that is required.
        IF (i_scale_esft(i_band, i_gas) == IP_scale_term) THEN
          CALL scale_absorb(ierr, n_profile, n_layer &
            , gas_mix_ratio(1, 1, i_gas), p, t &
            , i_top &
            , gas_frac_rescaled(1, 1, i_gas) &
            , i_scale_fnc(i_band, i_gas) &
            , p_reference(i_gas, i_band) &
            , t_reference(i_gas, i_band) &
            , scale_vector(1, iex, i_band, i_gas) &
            , l_doppler(i_gas), doppler_correction(i_gas) &
            , nd_profile, nd_layer &
            , nd_scale_variable &
            )
          IF (ierr /= i_normal) RETURN
        ENDIF
!
!       Set the appropriate boundary terms for the total
!       upward and downward fluxes.
!
        IF ( (i_angular_integration == IP_two_stream).OR. &
             (i_angular_integration == IP_ir_gauss) ) THEN
!
          IF (isolir == IP_solar) THEN
!           Solar region.
            DO l=1, n_profile
              d_planck_flux_surface(l)=0.0e+00_RealK
              flux_inc_down(l)=solar_irrad(l)/zen_0(l)
              flux_inc_direct(l)=solar_irrad(l)/zen_0(l)
            ENDDO
          ELSEIF (isolir == IP_infra_red) THEN
!           Infra-red region.
            DO l=1, n_profile
              flux_inc_direct(l)=0.0e+00_RealK
              flux_inc_down(l)=-planck_flux_top(l)
              d_planck_flux_surface(l) &
                =(1.0e+00_RealK-rho_alb(l, IP_surf_alb_diff)) &
                *(planck_flux_ground(l)-planck_flux_bottom(l))
            ENDDO
          ENDIF
!
        ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
          IF (isolir == IP_solar) THEN
            DO l=1, n_profile
              i_direct_part(l, 0)=solar_irrad(l)
              flux_inc_down(l)=0.0e+00_RealK
            ENDDO
          ELSE
            DO l=1, n_profile
              flux_inc_down(l)=-planck_flux_top(l)
              d_planck_flux_surface(l) &
                =planck_flux_ground(l)-planck_flux_bottom(l)
            ENDDO
          ENDIF
!
        ENDIF
!
!       Assign the monochromatic absorption coefficient.
        k_esft_mono(i_gas)=k_esft(iex, i_band, i_gas)
!
        CALL gas_optical_properties(n_profile, n_layer &
          , 1, i_gas_pointer, k_esft_mono &
          , gas_frac_rescaled &
          , k_gas_abs &
          , nd_profile, nd_layer, nd_species &
          )
!
!
        CALL monochromatic_radiance(ierr &
!                        Atmospheric properties
          , n_profile, n_layer, d_mass &
!                        Angular integration
          , i_angular_integration, i_2stream &
          , l_rescale, n_order_gauss &
          , n_order_phase, ms_min, ms_max, i_truncation, ls_local_trunc &
          , accuracy_adaptive, euler_factor &
          , i_sph_algorithm, i_sph_mode &
!                       Precalculated angular arrays
          , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
          , i_scatter_method &
!                        Options for solver
          , i_solver &
!                        Gaseous propreties
          , k_gas_abs &
!                        Options for equivalent extinction
          , .false., dummy_ke &
!                        Spectral region
          , isolir &
!                        Infra-red properties
          , diff_planck_band &
          , l_ir_source_quad, diff_planck_band_2 &
!                        Conditions at TOA
          , zen_0, zen_00, flux_inc_direct, flux_inc_down & !hmjb
          , i_direct_part &
!                        Surface properties
          , d_planck_flux_surface &
          , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
          , f_brdf, brdf_sol, brdf_hemi &
          , ss_prop &
!                        Cloudy properties
          , l_cloud, i_cloud &
!                        Cloud geometry
          , n_cloud_top &
          , n_cloud_type, frac_cloud &
          , n_region, k_clr, i_region_cloud, frac_region &
          , w_free, w_cloud, cloud_overlap &
          , n_column_slv, list_column_slv &
          , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
          , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
          , n_direction, direction &
!                        Calculated flxues
          , flux_direct_part, flux_total_part &
!                       Calculated Radiances
          , radiance_part &
!                       Calculated rates of photolysis
          , photolysis_part &
!                        Flags for clear-sky calculations
          , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
          , flux_direct_clear_part, flux_total_clear_part &
!                        Dimensions of arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_cloud_type, nd_region, nd_overlap_coeff &
          , nd_max_order, nd_sph_coeff &
          , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
          , nd_direction, nd_source_coeff &
          )
        IF (ierr /= i_normal) RETURN
!
!       Increment the radiances within the band. Each increment
!       represents a single k-term within a band weighted with
!       its own weighting factor, hence for each increment the
!       weighting is the product of these two factors: similarly
!       for the blue flux.
        weight_incr=weight_band*w_esft(iex, i_band,  i_gas)
        IF (l_blue_flux_surf) &
          weight_blue_incr=weight_blue*w_esft(iex, i_band,  i_gas)
        CALL augment_radiance(n_profile, n_layer &
          , i_angular_integration, i_sph_mode &
          , n_viewing_level, n_direction &
          , isolir, l_clear, l_initial, weight_incr &
          , l_blue_flux_surf, weight_blue_incr &
!                       Actual radiances
          , flux_direct, flux_down, flux_up &
          , flux_direct_blue_surf &
          , flux_down_blue_surf, flux_up_blue_surf &
          , i_direct, radiance, photolysis &
          , flux_direct_clear, flux_down_clear, flux_up_clear &
!                       Increments to radiances
          , flux_direct_part, flux_total_part &
          , i_direct_part, radiance_part, photolysis_part &
          , flux_direct_clear_part, flux_total_clear_part &
!                       Dimensions
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_layer, nd_viewing_level, nd_direction &
          )
!
!       Add in the increments from surface tiles
        IF (l_tile) THEN
          CALL augment_tiled_radiance(ierr &
            , n_point_tile, n_tile, list_tile &
            , i_angular_integration, isolir, l_initial &
            , weight_incr, l_blue_flux_surf, weight_blue_incr &
!                       Surface characteristics
            , rho_alb_tile &
!                       Actual radiances
            , flux_up_tile, flux_up_blue_tile &
!                       Increments to radiances
            , flux_direct_part(1, n_layer) &
            , flux_total_part(1, 2*n_layer+2) &
            , planck_flux_tile, planck_flux_bottom &
!                       Dimensions
            , nd_flux_profile, nd_point_tile, nd_tile &
            , nd_brdf_basis_fnc &
            )
          IF (ierr /= i_normal) RETURN
        ENDIF
!
!       After the first call to these routines quantities should be
!       incremented rather than initialized, until the flag is reset.
        l_initial=.false.
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLVE_BAND_ONE_GAS
!+ Subroutine to calculate the fluxes assuming random overlap.
!
! Method:
!       Monochromatic calculations are performed for each
!       combination of ESFT terms and the results are summed.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solve_band_random_overlap(ierr &
!                        Atmospheric Column
        , n_profile, n_layer, i_top, p, t, d_mass &
!                        Angular Integration
        , i_angular_integration, i_2stream &
        , n_order_phase, l_rescale, n_order_gauss &
        , ms_min, ms_max, i_truncation, ls_local_trunc &
        , accuracy_adaptive, euler_factor &
        , i_sph_algorithm, i_sph_mode &
!                     Precalculated angular arrays
        , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of Scattering
        , i_scatter_method &
!                        Options for solver
        , i_solver &
!                        Gaseous Properties
        , i_band, n_gas &
        , index_absorb, i_band_esft, i_scale_esft, i_scale_fnc &
        , k_esft, w_esft, scale_vector &
        , p_reference, t_reference &
        , gas_mix_ratio, gas_frac_rescaled &
        , l_doppler, doppler_correction &
!                        Spectral Region
        , isolir &
!                        Solar Properties
        , zen_0, zen_00, solar_irrad & !hmjb
!                        Infra-red Properties
        , planck_flux_top, planck_flux_bottom &
        , diff_planck_band &
        , l_ir_source_quad, diff_planck_band_2 &
!                        Surface Properties
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
        , planck_flux_ground &
!                       Tiling of the surface
        , l_tile, n_point_tile, n_tile, list_tile, rho_alb_tile &
        , planck_flux_tile &
!                       Optical Properties
        , ss_prop &
!                        Cloudy Properties
        , l_cloud, i_cloud &
!                        Cloud Geometry
        , n_cloud_top &
        , n_cloud_type, frac_cloud &
        , n_region, k_clr, i_region_cloud, frac_region &
        , w_free, w_cloud, cloud_overlap &
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
        , n_direction, direction &
!                       Weighting factor for the band
        , weight_band, l_initial &
!                        Fluxes Calculated
        , flux_direct, flux_down, flux_up &
!                       Calculcated radiances
        , i_direct, radiance &
!                       Calculcated rate of photolysis
        , photolysis &
!                        Flags for Clear-sky Fluxes
        , l_clear, i_solver_clear &
!                        Clear-sky Fluxes
        , flux_direct_clear, flux_down_clear, flux_up_clear &
!                       Tiled Surface Fluxes
        , flux_up_tile, flux_up_blue_tile &
!                       Special Surface Fluxes
        , l_blue_flux_surf, weight_blue &
        , flux_direct_blue_surf &
        , flux_down_blue_surf, flux_up_blue_surf &
!                       Dimensions
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_band, nd_species &
        , nd_esft_term, nd_scale_variable &
        , nd_cloud_type, nd_region, nd_overlap_coeff &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
        , nd_direction, nd_source_coeff &
        , nd_point_tile, nd_tile &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE angular_integration_pcf
      USE surface_spec_pcf
      USE spectral_region_pcf
      USE k_scale_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , nd_layer_clr &
!           Size allocated for totally clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_flux_profile &
!           Size allocated for profiles in arrays of fluxes
        , nd_radiance_profile &
!           Size allocated for profiles in arrays of radiances
        , nd_j_profile &
!           Size allocated for profiles in arrays of mean radiances
        , nd_band &
!           Maximum number of spectral bands
        , nd_species &
!           Maximum number of species
        , nd_esft_term &
!           Maximum number of ESFT terms
        , nd_scale_variable &
!           Maximum number of scale variables
        , nd_column &
!           Number of columns per point
        , nd_cloud_type &
!           Size allocated for cloud types
        , nd_region &
!           Size allocated for cloudy regions
        , nd_overlap_coeff &
!           Size allocated for cloudy overlap coefficients
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_sph_coeff &
!           Size allocated for spherical harmonic coefficients
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for orders of BRDFs
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_direction &
!           Size allocated for viewing directions
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_point_tile &
!           Size allocated for points where the surface is tiled
        , nd_tile
!           Size allocated for surface tiles
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!                        Atmospheric column
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , i_top
!           Top of vertical grid
      REAL  (RealK), Intent(IN) :: &
          d_mass(nd_profile, nd_layer) &
!           Mass thickness of each layer
        , p(nd_profile, nd_layer) &
!           Pressure
        , t(nd_profile, nd_layer)
!           Temperature
!
!                        Angular integration
      INTEGER, Intent(IN) :: &
          i_angular_integration &
!           Angular integration scheme
        , i_2stream &
!           Two-stream scheme
        , n_order_phase &
!           Maximum order of terms in the phase function used in
!           the direct calculation of spherical harmonics
        , n_order_gauss &
!           Order of gaussian integration
        , ms_min &
!           Lowest azimuthal order used
        , ms_max &
!           Highest azimuthal order used
        , i_truncation &
!           Type of spherical truncation used
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient of (m, m) for each m
        , ls_local_trunc(0: nd_max_order) &
!           Orders of truncation at each azimuthal order
        , i_sph_mode &
!           Mode in which the spherical solver is to be used
        , i_sph_algorithm
!           Algorithm used for spherical harmonic calculation
      LOGICAL, Intent(IN) :: &
          l_rescale
!           Rescale optical properties
      REAL  (RealK) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-Gordan coefficients
        , uplm_zero(nd_sph_coeff) &
!           Values of spherical harmonics at polar angles pi/2
        , uplm_sol(nd_radiance_profile, nd_sph_coeff) &
!           Values of spherical harmonics in the solar direction
        , accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last term of an alternating series
      REAL  (RealK), Intent(IN) :: &
          weight_band
!           Weighting factor for the current band
      LOGICAL, Intent(INOUT) :: &
          l_initial
!           Flag to initialize diagnostics
!
!                        Treatment of scattering
      INTEGER, Intent(IN) :: &
          i_scatter_method
!           Method of treating scattering
!
!                        Options for solver
      INTEGER, Intent(IN) :: &
          i_solver
!           Solver used
!
!                        Gaseous properties
      INTEGER, Intent(IN) :: &
          i_band &
!           Band being considered
        , n_gas &
!           Number of gases in band
        , index_absorb(nd_species, nd_band) &
!           List of absorbers in bands
        , i_band_esft(nd_band, nd_species) &
!           Number of terms in band
        , i_scale_esft(nd_band, nd_species) &
!           Type of ESFT scaling
        , i_scale_fnc(nd_band, nd_species)
!           Type of scaling function
      LOGICAL, Intent(IN) :: &
          l_doppler(nd_species)
!           Doppler broadening included
      REAL  (RealK), Intent(IN) :: &
          k_esft(nd_esft_term, nd_band, nd_species) &
!           Exponential ESFT terms
        , w_esft(nd_esft_term, nd_band, nd_species) &
!           Weights for ESFT
        , scale_vector(nd_scale_variable, nd_esft_term, nd_band &
            , nd_species) &
!           Absorber scaling parameters
        , p_reference(nd_species, nd_band) &
!           Reference scaling pressure
        , t_reference(nd_species, nd_band) &
!           Reference scaling temperature
        , gas_mix_ratio(nd_profile, nd_layer, nd_species) &
!           Gas mass mixing ratios
        , doppler_correction(nd_species)
!           Doppler broadening terms
      REAL  (RealK), Intent(OUT) :: &
          gas_frac_rescaled(nd_profile, nd_layer, nd_species)
!           Rescaled gas mass fractions
!
!                        Spectral region
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
!
!                        Solar properties
      REAL  (RealK), Intent(IN) :: &
          zen_0(nd_profile) &
        , zen_00(nd_profile, nd_layer) & !hmjb
!           Secants (two-stream) or cosines (spherical harmonics)
!           of the solar zenith angle
        , solar_irrad(nd_profile)
!           Incident solar irradiance in band
!
!                        Infra-red properties
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source function
      REAL  (RealK), Intent(IN) :: &
          planck_flux_top(nd_profile) &
!           Planckian flux at top
        , planck_flux_bottom(nd_profile) &
!           Planckian flux at bottom
        , diff_planck_band(nd_profile, nd_layer) &
!           Thermal source function
        , diff_planck_band_2(nd_profile, nd_layer)
!           2x2nd difference of Planckian in band
!
!                        Surface properties
      REAL  (RealK), Intent(IN) :: &
          planck_flux_ground(nd_profile)
!           Planckian flux at the surface temperature
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of truncation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!     Variables related to tiling of the surface
      LOGICAL, Intent(IN) :: &
          l_tile
!           Logical to allow invoke options
      INTEGER, Intent(IN) :: &
          n_point_tile &
!           Number of points to tile
        , n_tile &
!           Number of tiles used
        , list_tile(nd_point_tile)
!           List of points with surface tiling
      REAL  (RealK), Intent(IN) :: &
          rho_alb_tile(nd_point_tile, nd_brdf_basis_fnc, nd_tile) &
!           Weights for the basis functions of the BRDFs
!           at the tiled points
        , planck_flux_tile(nd_point_tile, nd_tile)
!           Local Planckian fluxes on surface tiles
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!                        Cloudy properties
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Cloud enabled
      INTEGER, Intent(IN) :: &
          i_cloud
!           Cloud scheme used
!
!                        Cloud geometry
      INTEGER, Intent(IN) :: &
          n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_type &
!           Number of types of cloud
        , n_region &
!           Number of cloudy regions
        , k_clr &
!           Index of clear-sky region
        , i_region_cloud(nd_cloud_type)
!           Regions in which types of clouds fall
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy fraction
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of types of clouds
        , w_free(nd_profile, id_ct: nd_layer) &
!           Clear-sky fraction
        , cloud_overlap(nd_profile, id_ct-1: nd_layer &
            , nd_overlap_coeff) &
!           Coefficients for transfer for energy at interfaces
        , area_column(nd_profile, nd_column) &
!           Areas of columns
        , frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fractions of total cloud occupied by each region
!
!
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2)
!           Viewing directions
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!                        Flags for clear-sky calculations
      LOGICAL, Intent(IN) :: &
          l_clear
!           Calculate clear-sky properties
      INTEGER, Intent(IN) :: &
          i_solver_clear
!           Clear solver used
!
!                        Calculated Fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct flux
        , flux_down(nd_flux_profile, 0: nd_layer) &
!           Total downward flux
        , flux_up(nd_flux_profile, 0: nd_layer)
!           Upward flux
!
!                       Calculated radiances
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_radiance_profile, 0: nd_layer) &
!           Direct solar irradiance on levels
        , radiance(nd_radiance_profile, nd_viewing_level &
            , nd_direction)
!           Radiances
!
!                       Calculated mean radiances
      REAL  (RealK), Intent(INOUT) :: &
          photolysis(nd_j_profile, nd_viewing_level)
!           Rates of photolysis
!
!                        Clear-sky fluxes calculated
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky direct flux
        , flux_down_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky total downward flux in band
        , flux_up_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky upward flux
        , flux_up_tile(nd_point_tile, nd_tile) &
!           Upward fluxes at tiled surface points
        , flux_up_blue_tile(nd_point_tile, nd_tile)
!           Upward blue fluxes at tiled surface points
!
!                         Special Diagnostics:
      LOGICAL, Intent(IN) :: &
          l_blue_flux_surf
!           Flag to calculate the blue flux at the surface
      REAL  (RealK), Intent(IN) :: &
          weight_blue
!           Weights for blue fluxes in this band
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_blue_surf(nd_flux_profile) &
!           Direct blue flux at the surface
        , flux_down_blue_surf(nd_flux_profile) &
!           Total downward blue flux at the surface
        , flux_up_blue_surf(nd_flux_profile)
!           Upward blue flux at the surface
!
!
!
!     Local variables.
      INTEGER &
           j &
!           Loop variable
        , k &
!           Loop variable
        , l
!           Loop variable
      INTEGER &
          i_gas_band &
!           Index of active gas
        , i_gas_pointer(nd_species) &
!           Pointer array for monochromatic ESFTs
        , i_esft_pointer(nd_species) &
!           Pointer to ESFT for gas
        , i_change &
!           Position of ESFT term to be altered
        , index_change &
!           Index of term to be altered
        , index_last &
!           Index of last gas in band
        , iex
!           Index of ESFT term
      REAL  (RealK) :: &
          k_esft_mono(nd_species) &
!           ESFT monochromatic exponents
        , k_gas_abs(nd_profile, nd_layer) &
!           Gaseous absorption
        , d_planck_flux_surface(nd_profile) &
!           Difference in Planckian fluxes between the surface and
!           the air
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , flux_inc_down(nd_profile) &
!           Incident downward flux
        , product_weight &
!           Product of ESFT weights
        , dummy_ke(nd_profile, nd_layer)
!           Dummy array (not used)
!
!     Monochromatic incrementing radiances:
      REAL  (RealK) :: &
          flux_direct_part(nd_flux_profile, 0: nd_layer) &
!           Partial direct flux
        , flux_total_part(nd_flux_profile, 2*nd_layer+2) &
!           Partial total flux
        , flux_direct_clear_part(nd_flux_profile, 0: nd_layer) &
!           Partial clear-sky direct flux
        , flux_total_clear_part(nd_flux_profile, 2*nd_layer+2)
!           Partial clear-sky total flux
      REAL  (RealK) :: &
          i_direct_part(nd_radiance_profile, 0: nd_layer) &
!           Partial solar irradiances
        , radiance_part(nd_radiance_profile, nd_viewing_level &
            , nd_direction)
!           Partial radiances
      REAL  (RealK) :: &
          photolysis_part(nd_j_profile, nd_viewing_level)
!           Partial rates of photolysis
      REAL  (RealK) :: &
          weight_incr &
!           Weight applied to increments
        , weight_blue_incr
!           Weight applied to blue increments
!
!
!     Subroutines called:
!      EXTERNAL &
!          scale_absorb, gas_optical_properties &
!        , monochromatic_radiance, augment_radiance
!
!
!
!     Set the number of active gases and initialize the pointers.
      DO k=1, n_gas
        i_gas_pointer(k)=index_absorb(k, i_band)
        i_esft_pointer(index_absorb(k, i_band))=1
      ENDDO
      index_last=index_absorb(n_gas, i_band)
!
!     Perform the initial rescaling of the gases other than the last.
!     Note: we rescale amounts as required. It would be more
!     efficient to save the rescaled amounts, but the storage
!     needed would become excessive for a multicolumn code. In a
!     single code the overhead would be less significant.
      DO k=1, n_gas-1
        i_gas_band=i_gas_pointer(k)
!       Initialize the monochromatic absorption coefficients.
        k_esft_mono(i_gas_band) &
          =k_esft(1, i_band, i_gas_band)
        IF (i_scale_esft(i_band, i_gas_band) == IP_scale_term) THEN
          CALL scale_absorb(ierr, n_profile, n_layer &
            , gas_mix_ratio(1, 1, i_gas_band), p, t &
            , i_top &
            , gas_frac_rescaled(1, 1, i_gas_band) &
            , i_scale_fnc(i_band, i_gas_band) &
            , p_reference(i_gas_band, i_band) &
            , t_reference(i_gas_band, i_band) &
            , scale_vector(1, 1, i_band, i_gas_band) &
            , l_doppler(i_gas_band), doppler_correction(i_gas_band) &
            , nd_profile, nd_layer &
            , nd_scale_variable &
            )
          IF (ierr /= i_normal) RETURN
        ENDIF
      ENDDO
!
!     Loop through the terms for the first absorber.
2000  i_esft_pointer(index_last)=0
      DO k=1, i_band_esft(i_band, index_last)
        i_esft_pointer(index_last) &
          =i_esft_pointer(index_last)+1
!
!       Set the ESFT coefficient and perform rescaling for the
!       last gas.
        iex=i_esft_pointer(index_last)
        k_esft_mono(index_last) &
          =k_esft(iex, i_band, index_last)
        IF (i_scale_esft(i_band, index_last) == IP_scale_term) THEN
          CALL scale_absorb(ierr, n_profile, n_layer &
            , gas_mix_ratio(1, 1, index_last), p, t &
            , i_top &
            , gas_frac_rescaled(1, 1, index_last) &
            , i_scale_fnc(i_band, index_last) &
            , p_reference(index_last, i_band) &
            , t_reference(index_last, i_band) &
            , scale_vector(1, iex, i_band, index_last) &
            , l_doppler(index_last) &
            , doppler_correction(index_last) &
            , nd_profile, nd_layer &
            , nd_scale_variable &
            )
          IF (ierr /= i_normal) RETURN
        ENDIF
!
!       Set the appropriate source terms for the two-stream
!       equations.
!       The product of the ESFT weights can be precalculated
!       for speed.
        product_weight=1.0e+00_RealK
        DO j=1, n_gas
          i_gas_band=i_gas_pointer(j)
          iex=i_esft_pointer(i_gas_band)
          product_weight=product_weight &
            *w_esft(iex, i_band, i_gas_band)
        ENDDO
!
        IF ( (i_angular_integration == IP_two_stream).OR. &
             (i_angular_integration == IP_ir_gauss) ) THEN
!
          IF (isolir == IP_solar) THEN
!
!           Solar region.
            DO l=1, n_profile
              d_planck_flux_surface(l)=0.0e+00_RealK
              flux_inc_down(l)=solar_irrad(l)/zen_0(l)
              flux_inc_direct(l)=solar_irrad(l)/zen_0(l)
            ENDDO
!
          ELSEIF (isolir == IP_infra_red) THEN
!           Infra-red region.
!
            DO l=1, n_profile
              flux_inc_direct(l)=0.0e+00_RealK
              flux_direct_part(l, n_layer)=0.0e+00_RealK
              flux_inc_down(l)=-planck_flux_top(l)
              d_planck_flux_surface(l) &
                =planck_flux_ground(l)-planck_flux_bottom(l)
            ENDDO
            IF (l_clear) THEN
              DO l=1, n_profile
                flux_direct_clear_part(l, n_layer)=0.0e+00_RealK
              ENDDO
            ENDIF
!
          ENDIF
!
        ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
          IF (isolir == IP_solar) THEN
            DO l=1, n_profile
              i_direct_part(l, 0)=solar_irrad(l)
              flux_inc_down(l)=0.0e+00_RealK
            ENDDO
          ELSE
            DO l=1, n_profile
              flux_inc_down(l)=-planck_flux_top(l)
              d_planck_flux_surface(l) &
                =planck_flux_ground(l)-planck_flux_bottom(l)
            ENDDO
          ENDIF
!
        ENDIF
!
        CALL gas_optical_properties(n_profile, n_layer &
          , n_gas, i_gas_pointer, k_esft_mono &
          , gas_frac_rescaled &
          , k_gas_abs &
          , nd_profile, nd_layer, nd_species &
          )
!
!
        CALL monochromatic_radiance(ierr &
!                        Atmospheric properties
          , n_profile, n_layer, d_mass &
!                        Angular integration
          , i_angular_integration, i_2stream &
          , l_rescale, n_order_gauss &
          , n_order_phase, ms_min, ms_max, i_truncation, ls_local_trunc &
          , accuracy_adaptive, euler_factor &
          , i_sph_algorithm, i_sph_mode &
!                       Precalculated angular arrays
          , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
          , i_scatter_method &
!                        Options for solver
          , i_solver &
!                        Gaseous propreties
          , k_gas_abs &
!                        Options for equivalent extinction
          , .false., dummy_ke &
!                        Spectral region
          , isolir &
!                        Infra-red properties
          , diff_planck_band &
          , l_ir_source_quad, diff_planck_band_2 &
!                        Conditions at TOA
          , zen_0, zen_00, flux_inc_direct, flux_inc_down & !hmjb
          , i_direct_part &
!                        Surface properties
          , d_planck_flux_surface &
          , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
          , f_brdf, brdf_sol, brdf_hemi &
!                       Optical properties
          , ss_prop &
!                        Cloudy properties
          , l_cloud, i_cloud &
!                        Cloud geometry
          , n_cloud_top &
          , n_cloud_type, frac_cloud &
          , n_region, k_clr, i_region_cloud, frac_region &
          , w_free, w_cloud, cloud_overlap &
          , n_column_slv, list_column_slv &
          , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
          , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
          , n_direction, direction &
!                        Calculated fluxes
          , flux_direct_part, flux_total_part &
!                       Calculated radiances
          , radiance_part &
!                       Calculated rate of photolysis
          , photolysis_part &
!                        Flags for clear-sky calculations
          , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
          , flux_direct_clear_part, flux_total_clear_part &
!                        Dimensions of arrays
          , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_cloud_type, nd_region, nd_overlap_coeff &
          , nd_max_order, nd_sph_coeff &
          , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
          , nd_direction, nd_source_coeff &
          )
        IF (ierr /= i_normal) RETURN
!
!       Increment the fluxes within the band.
        weight_incr=weight_band*product_weight
        IF (l_blue_flux_surf) &
          weight_blue_incr=weight_blue*product_weight
        CALL augment_radiance(n_profile, n_layer &
          , i_angular_integration, i_sph_mode &
          , n_viewing_level, n_direction &
          , isolir, l_clear, l_initial, weight_incr &
          , l_blue_flux_surf, weight_blue_incr &
!                       Actual radiances
          , flux_direct, flux_down, flux_up &
          , flux_direct_blue_surf &
          , flux_down_blue_surf, flux_up_blue_surf &
          , i_direct, radiance, photolysis &
          , flux_direct_clear, flux_down_clear, flux_up_clear &
!                       Increments to radiances
          , flux_direct_part, flux_total_part &
          , i_direct_part, radiance_part, photolysis_part &
          , flux_direct_clear_part, flux_total_clear_part &
!                       Dimensions
          , nd_flux_profile, nd_radiance_profile, nd_j_profile &
          , nd_layer, nd_viewing_level, nd_direction &
          )
!
!       Add in the increments from surface tiles
        IF (l_tile) THEN
          CALL augment_tiled_radiance(ierr &
            , n_point_tile, n_tile, list_tile &
            , i_angular_integration, isolir, l_initial &
            , weight_incr, l_blue_flux_surf, weight_blue_incr &
!                       Surface characteristics
            , rho_alb_tile &
!                       Actual radiances
            , flux_up_tile, flux_up_blue_tile &
!                       Increments to radiances
            , flux_direct_part(1, n_layer) &
            , flux_total_part(1, 2*n_layer+2) &
            , planck_flux_tile, planck_flux_bottom &
!                       Dimensions
            , nd_flux_profile, nd_point_tile, nd_tile &
            , nd_brdf_basis_fnc &
            )
          IF (ierr /= i_normal) RETURN
        ENDIF
!
!       After the first call to these routines quantities should be
!       incremented rather than initialized, until the flag is reset.
        l_initial=.false.
!
      ENDDO
!
      IF (n_gas > 1) THEN
!       Increment the ESFT pointers for the next pass through
!       the loop above. I_CHANGE is the ordinal of the gas,
!       the pointer of which is to be changed.
        i_change=n_gas-1
2001    index_change=index_absorb(i_change, i_band)
        IF (i_band_esft(i_band, index_change) &
           > i_esft_pointer(index_change)) THEN
          i_esft_pointer(index_change) &
            =i_esft_pointer(index_change)+1
!         Rescale the amount of this gas and advance the ESFT term.
          k_esft_mono(index_change) &
            =k_esft(i_esft_pointer(index_change) &
            , i_band, index_change)
          IF (i_scale_esft(i_band, index_change) == IP_scale_term) &
               THEN
            CALL scale_absorb(ierr, n_profile, n_layer &
              , gas_mix_ratio(1, 1, index_change), p, t &
              , i_top &
              , gas_frac_rescaled(1, 1, index_change) &
              , i_scale_fnc(i_band, index_change) &
              , p_reference(index_change, i_band) &
              , t_reference(index_change, i_band) &
              , scale_vector(1, i_esft_pointer(index_change) &
              , i_band, index_change) &
              , l_doppler(index_change) &
              , doppler_correction(index_change) &
              , nd_profile, nd_layer &
              , nd_scale_variable &
              )
            IF (ierr /= i_normal) RETURN
          ENDIF
          goto 2000
        ELSE IF (i_change > 1) THEN
!         All terms for this absorber have been done:
!         reset its pointer to 1 and move to the next absorber.
          i_esft_pointer(index_change)=1
          k_esft_mono(index_change)=k_esft(1, i_band, index_change)
          i_change=i_change-1
          goto 2001
        ENDIF
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE SOLVE_BAND_RANDOM_OVERLAP
!+ Subroutine to calculate the fluxes within the band with no gases.
!
! Method:
!       Gaseous extinction is set to 0 and a monochromatic
!       calculation is performed.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solve_band_without_gas(ierr &
!                        Atmospheric column
        , n_profile, n_layer, d_mass &
!                        Angular integration
        , i_angular_integration, i_2stream &
        , n_order_phase, l_rescale, n_order_gauss &
        , ms_min, ms_max, i_truncation, ls_local_trunc &
        , accuracy_adaptive, euler_factor, i_sph_algorithm &
        , i_sph_mode &
!                        Precalculated angular arrays
        , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
        , i_scatter_method &
!                        Options for solver
        , i_solver &
!                        Spectral region
        , isolir &
!                        Solar properties
        , zen_0, zen_00, solar_irrad & !hmjb
!                        Infra-red properties
        , planck_flux_top, planck_flux_bottom &
        , diff_planck_band, l_ir_source_quad, diff_planck_band_2 &
!                        Surface properties
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
        , planck_flux_ground &
!                       Tiling of the surface
        , l_tile, n_point_tile, n_tile, list_tile, rho_alb_tile &
        , planck_flux_tile &
!                       Optical Properties
        , ss_prop &
!                        Cloudy properties
        , l_cloud, i_cloud &
!                        Cloud geometry
        , n_cloud_top &
        , n_cloud_type, frac_cloud &
        , n_region, k_clr, i_region_cloud, frac_region &
        , w_free, w_cloud, cloud_overlap &
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
        , n_direction, direction &
!                       Weighting factor for the band
        , weight_band, l_initial &
!                        Calculated fluxes
        , flux_direct, flux_down, flux_up &
!                       Calculated radiances
        , i_direct, radiance &
!                       Calculated rate of photolysis
        , photolysis &
!                       Flags for clear-sky fluxes
        , l_clear, i_solver_clear &
!                        Calculated clear-sky fluxes
        , flux_direct_clear, flux_down_clear, flux_up_clear &
!                       Tiled Surface Fluxes
        , flux_up_tile, flux_up_blue_tile &
!                       Special Surface Fluxes
        , l_blue_flux_surf, weight_blue &
        , flux_direct_blue_surf &
        , flux_down_blue_surf, flux_up_blue_surf &
!                        Dimensions of arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_cloud_type, nd_region, nd_overlap_coeff &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
        , nd_direction, nd_source_coeff &
        , nd_point_tile, nd_tile &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE spectral_region_pcf
      USE surface_spec_pcf
      USE error_pcf
      USE angular_integration_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_layer_clr &
!           Size allocated for totally clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_flux_profile &
!           Size allocated for profiles in arrays of fluxes
        , nd_radiance_profile &
!           Size allocated for profiles in arrays of radiances
        , nd_j_profile &
!           Size allocated for profiles in arrays of mean radiances
        , nd_column &
!           Size allocated for columns per point
        , nd_cloud_type &
!           Size allocated for types of clouds
        , nd_region &
!           Size allocated for regions of clouds
        , nd_overlap_coeff &
!           Size allocated for cloud overlap coefficients
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_sph_coeff &
!           Size allocated for coefficients of spherical harmonics
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for orders of BRDFs
        , nd_viewing_level &
!           Size allocated for levels where radiances are calculated
        , nd_direction &
!           Size allocated for viewing directions
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_point_tile &
!           Size allocated for points where the surface is tiled
        , nd_tile
!           Size allocated for surface tiles
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
!                        Atmospheric column
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
      REAL  (RealK), Intent(IN) :: &
          d_mass(nd_profile, nd_layer)
!           Mass thickness of each layer
!
!                        Angular integration
      INTEGER, Intent(IN) :: &
          i_angular_integration &
!           Angular integration scheme
        , i_2stream &
!           Two-stream scheme
        , n_order_phase &
!           Maximum order of terms in the phase function used in
!           the direct calculation of spherical harmonics
        , n_order_gauss &
!           Order of gaussian integration
        , ms_min &
!           Lowest azimuthal order used
        , ms_max &
!           Highest azimuthal order used
        , i_truncation &
!           Type of spherical truncation used
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient of (m, m) for each m
        , ls_local_trunc(0: nd_max_order) &
!           Orders of truncation at each azimuthal order
        , i_sph_mode &
!           Mode in which the spherical solver is being used
        , i_sph_algorithm
!           Algorithm used for spherical harmonic calculation
      LOGICAL, Intent(IN) :: &
          l_rescale
!           Rescale optical properties
      REAL  (RealK) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-Gordan coefficients
        , uplm_zero(nd_sph_coeff) &
!           Values of spherical harmonics at polar angles pi/2
        , uplm_sol(nd_radiance_profile, nd_sph_coeff) &
!           Values of spherical harmonics in the solar direction
        , accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last term of an alternating series
!
      REAL  (RealK), Intent(IN) :: &
          weight_band
!           Weighting factor for the current band
      LOGICAL, Intent(INOUT) :: &
          l_initial
!           Flag to initialize diagnostics
!
!                        Treatment of scattering
      INTEGER, Intent(IN) :: &
          i_scatter_method
!           Method of treating scattering
!
!                        Options for solver
      INTEGER, Intent(IN) :: &
          i_solver
!           Two-stream solver used
!
!                        Spectral region
      INTEGER, Intent(IN) :: &
          isolir
!           Visible or IR
!
!                        Solar properties
      REAL  (RealK), Intent(IN) :: &
          zen_0(nd_profile) &
        , zen_00(nd_profile, nd_layer) & !hmjb
!           Secants (two-stream) or cosines (spherical harmonics)
!           of the solar zenith angle
        , solar_irrad(nd_profile)
!           Incident solar irradiance in the band
!
!                        Infra-red properties
      REAL  (RealK), Intent(IN) :: &
          planck_flux_top(nd_profile) &
!           Planck function at bottom of column
        , planck_flux_bottom(nd_profile) &
!           Planck function at bottom of column
        , diff_planck_band(nd_profile, nd_layer) &
!           Differences in the Planckian function (bottom-top) across
!           layers
        , diff_planck_band_2(nd_profile, nd_layer)
!           Twice the second difference of Planckian in band
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source function
!
!                        Surface properties
      REAL  (RealK), Intent(IN) :: &
          planck_flux_ground(nd_profile)
!           Thermal source at surface in band
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of truncation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!     Variables related to tiling of the surface
      LOGICAL, Intent(IN) :: &
          l_tile
!           Logical to allow invoke options
      INTEGER, Intent(IN) :: &
          n_point_tile &
!           Number of points to tile
        , n_tile &
!           Number of tiles used
        , list_tile(nd_point_tile)
!           List of points with surface tiling
      REAL  (RealK), Intent(IN) :: &
          rho_alb_tile(nd_point_tile, nd_brdf_basis_fnc, nd_tile) &
!           Weights for the basis functions of the BRDFs
!           at the tiled points
        , planck_flux_tile(nd_point_tile, nd_tile)
!           Local Planckian fluxes on surface tiles
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!                        Cloudy properties
      LOGICAL, Intent(IN) :: &
          l_cloud
!           Clouds required
      INTEGER, Intent(IN) :: &
          i_cloud
!           Cloud scheme used
!
!                        Cloud geometry
      INTEGER, Intent(IN) :: &
          n_cloud_top &
!           Topmost cloudy layer
        , n_cloud_type &
!           Number of types of clouds
        , n_region &
!           Number of cloudy regions
        , k_clr &
!           Index of clear-sky region
        , i_region_cloud(nd_cloud_type)
!           Regions in which types of clouds fall
!
!     Cloud geometry
      INTEGER, Intent(IN) :: &
          n_column_slv(nd_profile) &
!           Number of columns to be solved in each profile
        , list_column_slv(nd_profile, nd_column) &
!           List of columns requiring an actual solution
        , i_clm_lyr_chn(nd_profile, nd_column) &
!           Layer in the current column to change
        , i_clm_cld_typ(nd_profile, nd_column)
!           Type of cloud to introduce in the changed layer
      REAL  (RealK), Intent(IN) :: &
          w_free(nd_profile, id_ct: nd_layer) &
!           Clear-sky fraction
        , w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy fraction
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of types of clouds
        , cloud_overlap(nd_profile, id_ct-1: nd_layer, nd_overlap_coeff) &
!           Coefficients for transfer for energy at interfaces
        , area_column(nd_profile, nd_column) &
!           Areas of columns
        , frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fractions of total cloud occupied by each region
!
!
      INTEGER, Intent(IN) :: &
          n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction
!           Number of viewing directions
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2)
!           Viewing directions
!
!                        Calculated fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct flux
        , flux_down(nd_flux_profile, 0: nd_layer) &
!           Total downward flux
        , flux_up(nd_flux_profile, 0: nd_layer)
!           Upward flux
!
!                       Calculated radiances
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_radiance_profile, 0: nd_layer) &
!           Direct solar irradiance on levels
        , radiance(nd_radiance_profile, nd_viewing_level &
            , nd_direction)
!           Radiances
!
!                       Calculated rates of photolysis
      REAL  (RealK), Intent(INOUT) :: &
          photolysis(nd_j_profile, nd_viewing_level)
!           Rates of photolysis
!
!                        Flags for clear-sky fluxes
      LOGICAL, Intent(IN) :: &
          l_clear
!           Calculate net clear-sky properties
      INTEGER, Intent(IN) :: &
          i_solver_clear
!           Clear solver used
!
!                        Calculated clear-sky fluxes
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky direct flux
        , flux_down_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky total downward flux
        , flux_up_clear(nd_flux_profile, 0: nd_layer) &
!           Clear-sky upward flux
        , flux_up_tile(nd_point_tile, nd_tile) &
!           Upward fluxes at tiled surface points
        , flux_up_blue_tile(nd_point_tile, nd_tile)
!           Upward blue fluxes at tiled surface points
!
!                        Special Diagnostics:
      LOGICAL, Intent(IN) :: &
          l_blue_flux_surf
!           Flag to calculate blue fluxes at the surface
      REAL  (RealK), Intent(IN) :: &
          weight_blue
!           Weights for blue fluxes in this band
      REAL  (RealK), Intent(INOUT) :: &
          flux_direct_blue_surf(nd_flux_profile) &
!           Direct blue flux at the surface
        , flux_down_blue_surf(nd_flux_profile) &
!           Total downward blue flux at the surface
        , flux_up_blue_surf(nd_flux_profile)
!           Upward blue flux at the surface
!
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          flux_inc_direct(nd_profile) &
!           Incident direct flux
        , flux_inc_down(nd_profile) &
!           Incident downward flux
        , d_planck_flux_surface(nd_profile) &
!           Ground source function
        , k_null(nd_profile, nd_layer) &
!           Null vector for call to subroutine
        , dummy_ke(nd_profile, nd_layer)
!           Dummy array (not used)
!
!     Monochromatic incrementing radiances:
      REAL  (RealK) :: &
          flux_direct_band(nd_flux_profile, 0: nd_layer) &
!           Increment to direct flux
        , flux_total_band(nd_flux_profile, 2*nd_layer+2) &
!           Increment to total flux
        , flux_direct_clear_band(nd_flux_profile, 0: nd_layer) &
!           Increment to clear direct flux
        , flux_total_clear_band(nd_flux_profile, 2*nd_layer+2)
!           Increment to clear total flux
!                       Increments to Radiances
      REAL  (RealK) :: &
          i_direct_band(nd_radiance_profile, 0: nd_layer) &
!           Increments to the solar irradiance
        , radiance_band(nd_radiance_profile, nd_viewing_level &
            , nd_direction)
!           Increments to the radiance
      REAL  (RealK) :: &
          photolysis_band(nd_j_profile, nd_viewing_level)
!           Increments to the rate of photolysis
!
!     Subroutines called:
!      EXTERNAL &
!          monochromatic_radiance
!
!
!
!     Set the appropriate total upward and downward fluxes
!     at the boundaries.
!
      IF ( (i_angular_integration == IP_two_stream).OR. &
           (i_angular_integration == IP_ir_gauss) ) THEN
        IF (isolir == IP_solar) THEN
!         Visible region.
          DO l=1, n_profile
            d_planck_flux_surface(l)=0.0e+00_RealK
            flux_inc_down(l)=solar_irrad(l)/zen_0(l)
            flux_inc_direct(l)=solar_irrad(l)/zen_0(l)
          ENDDO
        ELSEIF (isolir == IP_infra_red) THEN
!         Infra-red region.
          DO l=1, n_profile
            flux_inc_direct(l)=0.0e+00_RealK
            flux_direct_band(l, n_layer)=0.0e+00_RealK
            flux_inc_down(l)=-planck_flux_top(l)
            d_planck_flux_surface(l) &
              =planck_flux_ground(l)-planck_flux_bottom(l)
          ENDDO
          IF (l_clear) THEN
            DO l=1, n_profile
              flux_direct_clear_band(l, n_layer)=0.0e+00_RealK
            ENDDO
          ENDIF
        ENDIF
!
      ELSE IF (i_angular_integration == IP_spherical_harmonic) THEN
!
        IF (isolir == IP_solar) THEN
          DO l=1, n_profile
            i_direct_band(l, 0)=solar_irrad(l)
            flux_inc_down(l)=0.0e+00_RealK
          ENDDO
        ELSE
          DO l=1, n_profile
            flux_inc_down(l)=-planck_flux_top(l)
            d_planck_flux_surface(l) &
              =planck_flux_ground(l)-planck_flux_bottom(l)
          ENDDO
        ENDIF
!
      ENDIF
!
      DO i=1, n_layer
        DO l=1, n_profile
          k_null(l, i)=0.0e+00_RealK
        ENDDO
      ENDDO
!
!
      CALL monochromatic_radiance(ierr &
!                        Atmospheric properties
        , n_profile, n_layer, d_mass &
!                        Angular integration
        , i_angular_integration, i_2stream &
        , l_rescale, n_order_gauss &
        , n_order_phase, ms_min, ms_max, i_truncation, ls_local_trunc &
        , accuracy_adaptive, euler_factor, i_sph_algorithm &
        , i_sph_mode &
!                        Precalculated angular arrays
        , ia_sph_mm, cg_coeff, uplm_zero, uplm_sol &
!                        Treatment of scattering
        , i_scatter_method &
!                        Options for solver
        , i_solver &
!                        Gaseous propreties
        , k_null &
!                        Options for equivalent extinction
        , .false., dummy_ke &
!                        Spectral region
        , isolir &
!                        Infra-red properties
        , diff_planck_band, l_ir_source_quad, diff_planck_band_2 &
!                        Conditions at TOA
        , zen_0, zen_00, flux_inc_direct, flux_inc_down &
        , i_direct_band &
!                        Surface properties
        , d_planck_flux_surface &
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
!                       Optical properties
        , ss_prop &
!                        Cloudy properties
        , l_cloud, i_cloud &
!                        Cloud geometry
        , n_cloud_top &
        , n_cloud_type, frac_cloud &
        , n_region, k_clr, i_region_cloud, frac_region &
        , w_free, w_cloud, cloud_overlap &
        , n_column_slv, list_column_slv &
        , i_clm_lyr_chn, i_clm_cld_typ, area_column &
!                       Levels for calculating radiances
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
        , n_direction, direction &
!                        Calculated Flxues
        , flux_direct_band, flux_total_band &
!                       Calculated radiances
        , radiance_band &
!                       Calculated rate of photolysis
        , photolysis_band &
!                        Flags for clear-sky calculations
        , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
        , flux_direct_clear_band, flux_total_clear_band &
!                        Dimensions of arrays
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_column &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_cloud_type, nd_region, nd_overlap_coeff &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc, nd_viewing_level &
        , nd_direction, nd_source_coeff &
        )
!
!     Add the increments to the cumulative fluxes.
      CALL augment_radiance(n_profile, n_layer &
        , i_angular_integration, i_sph_mode &
        , n_viewing_level, n_direction &
        , isolir, l_clear &
        , l_initial, weight_band &
        , l_blue_flux_surf, weight_blue &
!                       Actual radiances
        , flux_direct, flux_down, flux_up &
        , flux_direct_blue_surf &
        , flux_down_blue_surf, flux_up_blue_surf &
        , i_direct, radiance, photolysis &
        , flux_direct_clear, flux_down_clear, flux_up_clear &
!                       Increments to radiances
        , flux_direct_band, flux_total_band &
        , i_direct_band, radiance_band, photolysis_band &
        , flux_direct_clear_band, flux_total_clear_band &
!                       Dimensions
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_layer, nd_viewing_level, nd_direction &
        )
!
!     Add in the increments from surface tiles
      IF (l_tile) THEN
        CALL augment_tiled_radiance(ierr &
          , n_point_tile, n_tile, list_tile &
          , i_angular_integration, isolir, l_initial &
          , weight_band, l_blue_flux_surf, weight_blue &
!                       Surface characteristics
          , rho_alb_tile &
!                       Actual radiances
          , flux_up_tile, flux_up_blue_tile &
!                       Increments to radiances
          , flux_direct_band(1, n_layer) &
          , flux_total_band(1, 2*n_layer+2) &
          , planck_flux_tile, planck_flux_bottom &
!                       Dimensions
          , nd_flux_profile, nd_point_tile, nd_tile &
          , nd_brdf_basis_fnc &
          )
        IF (ierr /= i_normal) RETURN
      ENDIF
!
!     After the first call to these routines quantities should be
!     incremented rather than initialized, until the flag is reset.
      l_initial=.false.
!
!
!
      RETURN
      END SUBROUTINE SOLVE_BAND_WITHOUT_GAS
!+ Subroutine to calculate fluxes in a homogeneous column directly.
!
! Method:
!       Straightforward.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solver_homogen_direct(n_profile, n_layer &
        , trans, reflect &
        , s_down, s_up &
        , isolir, diffuse_albedo, direct_albedo &
        , flux_direct_ground, flux_inc_down &
        , d_planck_flux_surface &
        , flux_total &
        , nd_profile, nd_layer &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
!
!
      IMPLICIT NONE
!
!
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer
!           Size allocated for atmospheric layers
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , isolir
!           Spectral region
      REAL  (RealK), Intent(IN) :: &
          trans(nd_profile, nd_layer) &
!           Transmission coefficient
        , reflect(nd_profile, nd_layer) &
!           Reflection coefficient
        , s_down(nd_profile, nd_layer) &
!           Downward diffuse source
        , s_up(nd_profile, nd_layer) &
!           Upward diffuse source
        , diffuse_albedo(nd_profile) &
!           Diffuse surface albedo
        , direct_albedo(nd_profile) &
!           Direct surface albedo
        , d_planck_flux_surface(nd_profile) &
!           Difference between the Planckian flux at the surface
!           temperature and that of the overlaying air
        , flux_inc_down(nd_profile) &
!           Incident total flux
        , flux_direct_ground(nd_profile)
!           Direct flux at ground level
!
      REAL  (RealK), Intent(OUT) :: &
          flux_total(nd_profile, 2*nd_layer+2)
!           Total flux
!
!     Declaration of local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
      REAL  (RealK) :: &
          alpha(nd_profile, nd_layer+1) &
!           Combined albedo of lower layers
        , beta(nd_profile, nd_layer) &
!           Working array
        , gamma(nd_profile, nd_layer) &
!           Working array
        , h(nd_profile, nd_layer) &
!           Working array
        , s_up_prime(nd_profile, nd_layer+1)
!           Modified upward source function
!
!
!
!     Initialization at the bottom for upward elimination:
      IF (isolir == IP_solar) THEN
        DO l=1, n_profile
          alpha(l, n_layer+1)=diffuse_albedo(l)
          s_up_prime(l, n_layer+1) &
            =(direct_albedo(l)-diffuse_albedo(l)) &
            *flux_direct_ground(l)
        ENDDO
      ELSE IF (isolir == IP_infra_red) THEN
        DO l=1, n_profile
          alpha(l, n_layer+1)=diffuse_albedo(l)
          s_up_prime(l, n_layer+1) &
            =(1.0e+00_RealK-diffuse_albedo(l)) &
            *d_planck_flux_surface(l)
        ENDDO
      ENDIF
!
!     Eliminating loop:
      DO i=n_layer, 1, -1
        DO l=1, n_profile
          beta(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-alpha(l, i+1)*reflect(l, i))
          gamma(l, i)=alpha(l, i+1)*trans(l, i)
          h(l, i)=s_up_prime(l, i+1)+alpha(l, i+1)*s_down(l, i)
          alpha(l, i)=reflect(l, i) &
            +beta(l, i)*gamma(l, i)*trans(l, i)
          s_up_prime(l, i)=s_up(l, i)+beta(l, i)*trans(l, i)*h(l, i)
        ENDDO
      ENDDO
!
!     Initialize for backward substitution.
      DO l=1, n_profile
        flux_total(l, 2)=flux_inc_down(l)
        flux_total(l, 1)=alpha(l, 1)*flux_total(l, 2)+s_up_prime(l, 1)
      ENDDO
!
!     Backward substitution:
      DO i=1, n_layer
        DO l=1, n_profile
!         Upward flux
          flux_total(l, 2*i+1) &
            =beta(l, i)*(h(l, i)+gamma(l, i)*flux_total(l, 2*i))
!         Downward flux
          flux_total(l, 2*i+2)=s_down(l, i) &
            +trans(l, i)*flux_total(l, 2*i) &
            +reflect(l, i)*flux_total(l, 2*i+1)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLVER_HOMOGEN_DIRECT
!+ Subroutine to solve for mixed fluxes scattering without a matrix.
!
! Method:
!        Gaussian elimination in an upward direction is employed to
!       determine effective albedos for lower levels of the atmosphere.
!        This allows a downward pass of back-substitution to be carried
!        out to determine the upward and downward fluxes.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solver_mix_direct(n_profile, n_layer, n_cloud_top &
         , t, r, s_down, s_up &
         , t_cloud, r_cloud, s_down_cloud, s_up_cloud &
         , v11, v21, v12, v22 &
         , u11, u12, u21, u22 &
         , flux_inc_down &
         , source_ground_free, source_ground_cloud, albedo_surface_diff &
         , flux_total &
         , nd_profile, nd_layer, id_ct &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_ct
!           Topmost declared cloudy layer
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Topmost cloudy layer
      REAL  (RealK), Intent(IN) :: &
          t(nd_profile, nd_layer) &
!           Clear-sky transmission
        , r(nd_profile, nd_layer) &
!           Clear-sky reflection
        , s_down(nd_profile, nd_layer) &
!           Clear-sky downward source function
        , s_up(nd_profile, nd_layer) &
!           Clear-sky upward source function
        , t_cloud(nd_profile, nd_layer) &
!           Cloudy transmission
        , r_cloud(nd_profile, nd_layer) &
!           Cloudy reflection
        , s_down_cloud(nd_profile, nd_layer) &
!           Downward cloudy source function
        , s_up_cloud(nd_profile, nd_layer)
!           Upward cloudy source function
      REAL  (RealK), Intent(IN) :: &
          v11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , u11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , u12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , u21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , u22(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient
      REAL  (RealK), Intent(IN) :: &
          flux_inc_down(nd_profile) &
!           Incident flux
        , source_ground_free(nd_profile) &
!           Source from ground (clear sky)
        , source_ground_cloud(nd_profile) &
!           Source from ground (cloudy region)
        , albedo_surface_diff(nd_profile)
!           Diffuse albedo
      REAL  (RealK), Intent(OUT) :: &
          flux_total(nd_profile, 2*nd_layer+2)
!           Total flux
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!     Effective coupling albedos and source functions:
      REAL  (RealK) :: &
          alpha11(nd_profile, nd_layer+1) &
        , alpha22(nd_profile, nd_layer+1) &
        , alpha21(nd_profile, nd_layer+1) &
        , alpha12(nd_profile, nd_layer+1) &
        , g1(nd_profile, nd_layer+1) &
        , g2(nd_profile, nd_layer+1)
!     Terms for downward propagation:
      REAL  (RealK) :: &
          gamma11(nd_profile, nd_layer) &
        , gamma12(nd_profile, nd_layer) &
        , gamma21(nd_profile, nd_layer) &
        , gamma22(nd_profile, nd_layer) &
        , beta11_inv(nd_profile, nd_layer) &
        , beta21(nd_profile, nd_layer) &
        , beta22_inv(nd_profile, nd_layer) &
        , h1(nd_profile, nd_layer) &
        , h2(nd_profile, nd_layer)
!
!     Auxilairy numerical variables required only in the current layer:
      REAL  (RealK) :: &
          theta11 &
        , theta12 &
        , theta21 &
        , theta22 &
        , lambda &
        , lambda_bar
!
!     Temporary fluxes
      REAL  (RealK) :: &
          flux_down_1(nd_profile, 0: nd_layer) &
!           Downward fluxes outside clouds just below I''th level
        , flux_down_2(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below I''th level
        , flux_up_1(nd_profile, 0: nd_layer) &
!           Upward fluxes outside clouds just above I''th level
        , flux_up_2(nd_profile, 0: nd_layer)
!           Upward fluxes inside clouds just above I''th level
!
!
!
!     Initialize at the bottom of the column for upward elimination.
      DO l=1, n_profile
        alpha11(l, n_layer+1)=albedo_surface_diff(l)
        alpha22(l, n_layer+1)=albedo_surface_diff(l)
        alpha21(l, n_layer+1)=0.0e+00_RealK
        alpha12(l, n_layer+1)=0.0e+00_RealK
        g1(l, n_layer+1)=source_ground_free(l)
        g2(l, n_layer+1)=source_ground_cloud(l)
      ENDDO
!
!     Upward elimination through the cloudy layers.
      DO i=n_layer, n_cloud_top, -1
        DO l=1, n_profile
!
           theta11=alpha11(l, i+1)*v11(l, i)+alpha12(l, i+1)*v21(l, i)
           theta12=alpha11(l, i+1)*v12(l, i)+alpha12(l, i+1)*v22(l, i)
           theta21=alpha21(l, i+1)*v11(l, i)+alpha22(l, i+1)*v21(l, i)
           theta22=alpha21(l, i+1)*v12(l, i)+alpha22(l, i+1)*v22(l, i)
           beta21(l, i)=-theta21*r(l, i)
           beta22_inv(l, i)=1.0e+00_RealK &
             /(1.0e+00_RealK-theta22*r_cloud(l, i))
           gamma21(l, i)=theta21*t(l, i)
           gamma22(l, i)=theta22*t_cloud(l, i)
           h2(l, i)=g2(l, i+1)+theta21*s_down(l, i) &
             +theta22*s_down_cloud(l, i)
           lambda=theta12*r_cloud(l, i)*beta22_inv(l, i)
           beta11_inv(l, i)=1.0e+00_RealK &
             /(1.0e+00_RealK-theta11*r(l, i)+lambda*beta21(l, i))
           gamma11(l, i)=theta11*t(l, i)+lambda*gamma21(l, i)
           gamma12(l, i)=theta12*t_cloud(l, i)+lambda*gamma22(l, i)
           h1(l, i)=g1(l, i+1)+theta11*s_down(l, i) &
             +theta12*s_down_cloud(l, i)+lambda*h2(l, i)
           lambda=u22(l, i-1)*t_cloud(l, i)*beta22_inv(l, i)
           lambda_bar=(u21(l, i-1)*t(l, i)+lambda*beta21(l, i)) &
             *beta11_inv(l, i)
           alpha21(l, i)=u21(l, i-1)*r(l, i)+lambda*gamma21(l, i) &
             +lambda_bar*gamma11(l, i)
           alpha22(l, i)=u22(l, i-1)*r_cloud(l, i) &
             +lambda*gamma22(l, i)+lambda_bar*gamma12(l, i)
           g2(l, i)=u21(l, i-1)*s_up(l, i)+u22(l, i-1)*s_up_cloud(l, i) &
             +lambda*h2(l, i)+lambda_bar*h1(l, i)
!
           lambda=u12(l, i-1)*t_cloud(l, i)*beta22_inv(l, i)
           lambda_bar=(u11(l, i-1)*t(l, i)+lambda*beta21(l, i)) &
             *beta11_inv(l, i)
           alpha11(l, i)=u11(l, i-1)*r(l, i)+lambda*gamma21(l, i) &
             +lambda_bar*gamma11(l, i)
           alpha12(l, i)=u12(l, i-1)*r_cloud(l, i) &
             +lambda*gamma22(l, i)+lambda_bar*gamma12(l, i)
           g1(l, i)=u11(l, i-1)*s_up(l, i)+u12(l, i-1)*s_up_cloud(l, i) &
             +lambda*h2(l, i)+lambda_bar*h1(l, i)
!
        ENDDO
      ENDDO
!
!     The layer above the cloud: only one set of alphas is now needed.
!     This will not be presented if there is cloud in the top layer.
!
      IF (n_cloud_top > 1) THEN
!
        i=n_cloud_top-1
        DO l=1, n_profile
!
          IF (n_cloud_top < n_layer) THEN
!           If there is no cloud in the column the V''s will not be
!           assigned so an if test is required.
            theta11=alpha11(l, i+1)*v11(l, i)+alpha12(l, i+1)*v21(l, i)
          ELSE
            theta11=alpha11(l, i+1)
          ENDIF
!
          beta11_inv(l, i)=1.0e+00_RealK/(1.0e+00_realk-theta11*r(l, i))
          gamma11(l, i)=theta11*t(l, i)
          h1(l, i)=g1(l, i+1)+theta11*s_down(l, i)
!
          lambda=t(l, i)*beta11_inv(l, i)
          alpha11(l, i)=r(l, i)+lambda*gamma11(l, i)
          g1(l, i)=s_up(l, i)+lambda*h1(l, i)
!
        ENDDO
!
      ENDIF
!
!
      DO i=n_cloud_top-2, 1, -1
        DO l=1, n_profile
!
          beta11_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-alpha11(l, i+1)*r(l, i))
          gamma11(l, i)=alpha11(l, i+1)*t(l, i)
          h1(l, i)=g1(l, i+1)+alpha11(l, i+1)*s_down(l, i)
!
          lambda=t(l, i)*beta11_inv(l, i)
          alpha11(l, i)=r(l, i)+lambda*gamma11(l, i)
          g1(l, i)=s_up(l, i)+lambda*h1(l, i)
!
        ENDDO
      ENDDO
!
!
!     Initialize for downward back-substitution.
      DO l=1, n_profile
        flux_total(l, 2)=flux_inc_down(l)
      ENDDO
      IF (n_cloud_top > 1) THEN
        DO l=1, n_profile
          flux_total(l, 1)=alpha11(l, 1)*flux_total(l, 2)+g1(l, 1)
        ENDDO
      ELSE
        DO l=1, n_profile
          flux_total(l, 1)=g1(l, 1)+flux_inc_down(l) &
            *(v11(l, 0)*alpha11(l, 1)+v21(l, 0)*alpha12(l, 1))
        ENDDO
      ENDIF
!
!     Sweep downward through the clear-sky region, finding the downward
!     flux at the top of the layer and the upward flux at the bottom.
      DO i=1, n_cloud_top-1
        DO l=1, n_profile
          flux_total(l, 2*i+1)=(gamma11(l, i)*flux_total(l, 2*i) &
            +h1(l, i))*beta11_inv(l, i)
          flux_total(l, 2*i+2)=t(l, i)*flux_total(l, 2*i) &
            +r(l, i)*flux_total(l, 2*i+1)+s_down(l, i)
        ENDDO
      ENDDO
!
!     Pass into the top cloudy layer. Use FLUX_DOWN_[1,2] to hold,
!     provisionally, the downward fluxes just below the top of the
!     layer, then calculate the upward fluxes at the bottom and
!     finally the downward fluxes at the bottom of the layer.
      IF (n_cloud_top <= n_layer) THEN
!       If there are no clouds n_cloud_top may be out-of-bounds for
!       these arrays so an if test is required.
        i=n_cloud_top
        DO l=1, n_profile
          flux_down_1(l, i)=v11(l, i-1)*flux_total(l, 2*i)
          flux_down_2(l, i)=v21(l, i-1)*flux_total(l, 2*i)
          flux_up_1(l, i)=(gamma11(l, i)*flux_down_1(l, i) &
            +gamma12(l, i)*flux_down_2(l, i)+h1(l, i))*beta11_inv(l, i)
          flux_up_2(l, i)=(gamma21(l, i)*flux_down_1(l, i) &
            +gamma22(l, i)*flux_down_2(l, i)+h2(l, i) &
            -beta21(l, i)*flux_up_1(l, i))*beta22_inv(l, i)
          flux_down_1(l, i)=t(l, i)*flux_down_1(l, i) &
            +r(l, i)*flux_up_1(l, i)+s_down(l, i)
          flux_down_2(l, i)=t_cloud(l, i)*flux_down_2(l, i) &
            +r_cloud(l, i)*flux_up_2(l, i)+s_down_cloud(l, i)
        ENDDO
      ENDIF
!
!     The main loop of back-substitution. The provisional use of the
!     downward fluxes is as above.
      DO i=n_cloud_top+1, n_layer
        DO l=1, n_profile
          flux_down_1(l, i)=v11(l, i-1)*flux_down_1(l, i-1) &
            +v12(l, i-1)*flux_down_2(l, i-1)
          flux_down_2(l, i)=v21(l, i-1)*flux_down_1(l, i-1) &
            +v22(l, i-1)*flux_down_2(l, i-1)
          flux_up_1(l, i)=(gamma11(l, i)*flux_down_1(l, i) &
            +gamma12(l, i)*flux_down_2(l, i)+h1(l, i)) &
            *beta11_inv(l, i)
          flux_up_2(l, i)=(gamma21(l, i)*flux_down_1(l, i) &
            +gamma22(l, i)*flux_down_2(l, i) &
            -beta21(l, i)*flux_up_1(l, i)+h2(l, i)) &
            *beta22_inv(l, i)
          flux_down_1(l, i)=t(l, i)*flux_down_1(l, i) &
            +r(l, i)*flux_up_1(l, i)+s_down(l, i)
          flux_down_2(l, i)=t_cloud(l, i)*flux_down_2(l, i) &
            +r_cloud(l, i)*flux_up_2(l, i)+s_down_cloud(l, i)
        ENDDO
      ENDDO
!
!
!     Calculate the overall flux.
      DO i=n_cloud_top, n_layer
        DO l=1, n_profile
          flux_total(l, 2*i+1)=flux_up_1(l, i)+flux_up_2(l, i)
          flux_total(l, 2*i+2)=flux_down_1(l, i)+flux_down_2(l, i)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLVER_MIX_DIRECT
!+ Subroutine to solve for mixed fluxes scattering without a matrix.
!
! Method:
!        Gaussian elimination in an upward direction is employed to
!       determine effective albedos for lower levels of the atmosphere.
!        This allows a downward pass of back-substitution to be carried
!        out to determine the upward and downward fluxes.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!       1.1             10-06-06                Modified to allow shadowing
!                                               (R. J. Hogan)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solver_mix_direct_hogan(n_profile, n_layer, n_cloud_top &
         , t, r, s_down, s_up &
         , t_cloud, r_cloud, s_down_cloud, s_up_cloud &
         , v11, v21, v12, v22 &
         , u11, u12, u21, u22 &
         , flux_inc_down &
         , source_ground_free, source_ground_cloud, albedo_surface_diff &
         , flux_total &
         , nd_profile, nd_layer, id_ct &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_ct
!           Topmost declared cloudy layer
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Topmost cloudy layer
      REAL  (RealK), Intent(IN) :: &
          t(nd_profile, nd_layer) &
!           Clear-sky transmission
        , r(nd_profile, nd_layer) &
!           Clear-sky reflection
        , s_down(nd_profile, nd_layer) &
!           Clear-sky downward source function
        , s_up(nd_profile, nd_layer) &
!           Clear-sky upward source function
        , t_cloud(nd_profile, nd_layer) &
!           Cloudy transmission
        , r_cloud(nd_profile, nd_layer) &
!           Cloudy reflection
        , s_down_cloud(nd_profile, nd_layer) &
!           Downward cloudy source function
        , s_up_cloud(nd_profile, nd_layer)
!           Upward cloudy source function
      REAL  (RealK), Intent(IN) :: &
          v11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , u11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , u12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , u21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , u22(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient
      REAL  (RealK), Intent(IN) :: &
          flux_inc_down(nd_profile) &
!           Incident flux
        , source_ground_free(nd_profile) &
!           Source from ground (clear sky)
        , source_ground_cloud(nd_profile) &
!           Source from ground (cloudy region)
        , albedo_surface_diff(nd_profile)
!           Diffuse albedo
      REAL  (RealK), Intent(OUT) :: &
          flux_total(nd_profile, 2*nd_layer+2)
!           Total flux
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!     Effective coupling albedos and source functions:
      REAL  (RealK) :: &
          alpha11(nd_profile, nd_layer+1) &
        , alpha22(nd_profile, nd_layer+1) &
        , g1(nd_profile, nd_layer+1) &
        , g2(nd_profile, nd_layer+1)
!     Terms for downward propagation:
      REAL  (RealK) :: &
          gamma11(nd_profile, nd_layer) &
        , gamma22(nd_profile, nd_layer) &
        , beta11_inv(nd_profile, nd_layer) &
        , beta22_inv(nd_profile, nd_layer) &
        , h1(nd_profile, nd_layer) &
        , h2(nd_profile, nd_layer)
!
!     Auxilairy numerical variables required only in the current layer:
      REAL  (RealK) :: &
          theta11 &
        , theta22 &
        , lambda1 &
        , lambda2 &
        , lambda
!
!     Temporary fluxes
      REAL  (RealK) :: &
          flux_down_1(nd_profile, 0: nd_layer) &
!           Downward fluxes outside clouds just below I''th level
        , flux_down_2(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below I''th level
        , flux_up_1(nd_profile, 0: nd_layer) &
!           Upward fluxes outside clouds just above I''th level
        , flux_up_2(nd_profile, 0: nd_layer)
!           Upward fluxes inside clouds just above I''th level
!
!
!
!     Initialize at the bottom of the column for upward elimination.
      DO l=1, n_profile
        alpha11(l, n_layer+1)=albedo_surface_diff(l)
        alpha22(l, n_layer+1)=albedo_surface_diff(l)
        g1(l, n_layer+1)=source_ground_free(l)
        g2(l, n_layer+1)=source_ground_cloud(l)
      ENDDO
!
!     Upward elimination through the cloudy layers.
      DO i=n_layer, n_cloud_top, -1
        DO l=1, n_profile
!
            theta11=alpha11(l, i+1)*v11(l, i)+alpha22(l, i+1)*v21(l, i)
            theta22=alpha11(l, i+1)*v12(l, i)+alpha22(l, i+1)*v22(l, i)

            beta11_inv(l, i)=1.0_RealK/(1.0_RealK-theta11*r(l, i))
            gamma11(l, i)=theta11*t(l, i)
            h1(l, i)=g1(l, i+1)+theta11*s_down(l, i)

            beta22_inv(l, i)=1.0_RealK/(1.0_RealK-theta22*r_cloud(l, i))
            gamma22(l, i)=theta22*t_cloud(l, i)
            h2(l, i)=g2(l, i+1)+theta22*s_down_cloud(l, i)

            lambda1 = s_up(l, i)+h1(l, i)*t(l, i)*beta11_inv(l, i)
            lambda2 = s_up_cloud(l, i)+h2(l, i)*t_cloud(l, i) &
                 *beta22_inv(l, i)

            alpha11(l, i)=r(l, i) &
                 + theta11*t(l, i)*t(l, i)*beta11_inv(l, i)
            g1(l, i)=u11(l, i-1)*lambda1 + u12(l, i-1)*lambda2

            alpha22(l, i)=r_cloud(l, i) &
                 + theta22*t_cloud(l, i)*t_cloud(l, i)*beta22_inv(l, i)
            g2(l, i)=u21(l, i-1)*lambda1 + u22(l, i-1)*lambda2
!
        ENDDO
      ENDDO
!
!     The layer above the cloud: only one set of alphas is now needed.
!     This will not be presented if there is cloud in the top layer.
!
      IF (n_cloud_top > 1) THEN
!
        i=n_cloud_top-1
        DO l=1, n_profile
!
          IF (n_cloud_top < n_layer) THEN
!           If there is no cloud in the column the V''s will not be
!           assigned so an if test is required.
            theta11=alpha11(l, i+1)*v11(l, i)+alpha22(l, i+1)*v21(l, i)
          ELSE
            theta11=alpha11(l, i+1)
          ENDIF
!
          beta11_inv(l, i)=1.0e+00_RealK/(1.0e+00_realk-theta11*r(l, i))
          gamma11(l, i)=theta11*t(l, i)
          h1(l, i)=g1(l, i+1)+theta11*s_down(l, i)
!
          lambda=t(l, i)*beta11_inv(l, i)
          alpha11(l, i)=r(l, i)+lambda*gamma11(l, i)
          g1(l, i)=s_up(l, i)+lambda*h1(l, i)
!
        ENDDO
!
      ENDIF
!
!
      DO i=n_cloud_top-2, 1, -1
        DO l=1, n_profile
!
          beta11_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-alpha11(l, i+1)*r(l, i))
          gamma11(l, i)=alpha11(l, i+1)*t(l, i)
          h1(l, i)=g1(l, i+1)+alpha11(l, i+1)*s_down(l, i)
!
          lambda=t(l, i)*beta11_inv(l, i)
          alpha11(l, i)=r(l, i)+lambda*gamma11(l, i)
          g1(l, i)=s_up(l, i)+lambda*h1(l, i)
!
        ENDDO
      ENDDO
!
!
!     Initialize for downward back-substitution.
      DO l=1, n_profile
        flux_total(l, 2)=flux_inc_down(l)
      ENDDO
      IF (n_cloud_top > 1) THEN
        DO l=1, n_profile
          flux_total(l, 1)=alpha11(l, 1)*flux_total(l, 2)+g1(l, 1)
        ENDDO
      ELSE
        DO l=1, n_profile
          flux_total(l, 1)=g1(l, 1)+flux_inc_down(l) &
            *(v11(l, 0)*alpha11(l, 1)+v21(l, 0)*alpha22(l, 1))
        ENDDO
      ENDIF
!
!     Sweep downward through the clear-sky region, finding the downward
!     flux at the top of the layer and the upward flux at the bottom.
      DO i=1, n_cloud_top-1
        DO l=1, n_profile
          flux_total(l, 2*i+1)=(gamma11(l, i)*flux_total(l, 2*i) &
            +h1(l, i))*beta11_inv(l, i)
          flux_total(l, 2*i+2)=t(l, i)*flux_total(l, 2*i) &
            +r(l, i)*flux_total(l, 2*i+1)+s_down(l, i)
        ENDDO
      ENDDO
!
!     Pass into the top cloudy layer. Use FLUX_DOWN_[1,2] to hold,
!     provisionally, the downward fluxes just below the top of the
!     layer, then calculate the upward fluxes at the bottom and
!     finally the downward fluxes at the bottom of the layer.
      IF (n_cloud_top <= n_layer) THEN
!       If there are no clouds n_cloud_top may be out-of-bounds for
!       these arrays so an if test is required.
        i=n_cloud_top
        DO l=1, n_profile
           flux_down_1(l, i)=v11(l, i-1)*flux_total(l, 2*i)
           flux_down_2(l, i)=v21(l, i-1)*flux_total(l, 2*i)
           flux_up_1(l, i)=(gamma11(l, i)*flux_down_1(l, i) &
              +h1(l, i))*beta11_inv(l, i)
           flux_up_2(l, i)=(gamma22(l, i)*flux_down_2(l, i) &
                +h2(l, i))*beta22_inv(l, i)
           flux_down_1(l, i)=t(l, i)*flux_down_1(l, i) &
              +r(l, i)*flux_up_1(l, i)+s_down(l, i)
           flux_down_2(l, i)=t_cloud(l, i)*flux_down_2(l, i) &
              +r_cloud(l, i)*flux_up_2(l, i)+s_down_cloud(l, i)
        ENDDO
      ENDIF
!
!     The main loop of back-substitution. The provisional use of the
!     downward fluxes is as above.
      DO i=n_cloud_top+1, n_layer
        DO l=1, n_profile
            flux_down_1(l, i)=v11(l, i-1)*flux_down_1(l, i-1) &
               +v12(l, i-1)*flux_down_2(l, i-1)
            flux_down_2(l, i)=v21(l, i-1)*flux_down_1(l, i-1) &
               +v22(l, i-1)*flux_down_2(l, i-1)
            flux_up_1(l, i)=(gamma11(l, i)*flux_down_1(l, i) &
               +h1(l, i))*beta11_inv(l, i)
            flux_up_2(l, i)=(gamma22(l, i)*flux_down_2(l, i) &
               +h2(l, i))*beta22_inv(l, i)
            flux_down_1(l, i)=t(l, i)*flux_down_1(l, i) &
               +r(l, i)*flux_up_1(l, i)+s_down(l, i)
            flux_down_2(l, i)=t_cloud(l, i)*flux_down_2(l, i) &
               +r_cloud(l, i)*flux_up_2(l, i)+s_down_cloud(l, i)
        ENDDO
      ENDDO
!
!
!     Calculate the overall flux.
      DO i=n_cloud_top, n_layer
        DO l=1, n_profile
          flux_total(l, 2*i+1)=flux_up_1(l, i)+flux_up_2(l, i)
          flux_total(l, 2*i+2)=flux_down_1(l, i)+flux_down_2(l, i)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLVER_MIX_DIRECT_HOGAN
!+ Subroutine to solve for triple overlaps with approximate scattering.
!
! Method:
!        The flux is propagated downwards, ignoring reflection terms.
!        since the routine uses differential fluxes, this effectively
!        treats the upward flux as Planckian at this point. Upward
!        fluxes are calculated using the newly available approximate
!        downward fluxes in the reflected terms.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solver_triple_app_scat(n_profile, n_layer, n_cloud_top &
         , t, r, s_down, s_up &
         , t_strat, r_strat, s_down_strat, s_up_strat &
         , t_conv, r_conv, s_down_conv, s_up_conv &
         , v11, v12, v13, v21, v22, v23, v31, v32, v33 &
         , u11, u12, u13, u21, u22, u23, u31, u32, u33 &
         , flux_inc_down &
         , source_ground_free, source_ground_strat &
         , source_ground_conv, albedo_surface_diff &
         , flux_total &
         , nd_profile, nd_layer, id_ct &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_ct
!           Topmost declared cloudy layer
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Topmost cloudy layer
      REAL  (RealK), Intent(IN) :: &
          t(nd_profile, nd_layer) &
!           Clear-sky transmission
        , r(nd_profile, nd_layer) &
!           Clear-sky reflection
        , s_down(nd_profile, nd_layer) &
!           Clear-sky downward source function
        , s_up(nd_profile, nd_layer) &
!           Clear-sky upward source function
        , t_strat(nd_profile, nd_layer) &
!           Stratfiform transmission
        , r_strat(nd_profile, nd_layer) &
!           Stratfiform reflection
        , s_down_strat(nd_profile, nd_layer) &
!           Downward stratfiform source function
        , s_up_strat(nd_profile, nd_layer) &
!           Upward stratfiform source function
        , t_conv(nd_profile, nd_layer) &
!           Convective transmission
        , r_conv(nd_profile, nd_layer) &
!           Convective reflection
        , s_down_conv(nd_profile, nd_layer) &
!           Downward convective source function
        , s_up_conv(nd_profile, nd_layer)
!           Upward convective source function
      REAL  (RealK), Intent(IN) :: &
          v11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v13(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v23(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v31(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v32(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v33(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient for downward radiation
      REAL  (RealK) :: &
          u11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u13(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u23(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u31(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u32(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u33(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient for upward radiation
      REAL  (RealK), Intent(IN) :: &
          flux_inc_down(nd_profile) &
!           Incident flux
        , source_ground_free(nd_profile) &
!           Source from ground (clear sky)
        , source_ground_strat(nd_profile) &
!           Source from ground (cloudy region)
        , source_ground_conv(nd_profile) &
!           Source from ground (cloudy region)
        , albedo_surface_diff(nd_profile)
!           Diffuse albedo
      REAL  (RealK), Intent(OUT) :: &
          flux_total(nd_profile, 2*nd_layer+2)
!           Total flux
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!
!     Temporary fluxes
      REAL  (RealK) :: &
          flux_down_1(nd_profile, 0: nd_layer) &
!           Downward fluxes outside clouds just below i''th level
        , flux_down_2(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below i''th level
        , flux_down_3(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below i''th level
        , flux_up_1(nd_profile, 0: nd_layer) &
!           Upward fluxes outside clouds just above i''th level
        , flux_up_2(nd_profile, 0: nd_layer) &
!           Upward fluxes inside clouds just above i''th level
        , flux_up_3(nd_profile, 0: nd_layer) &
!           Upward fluxes inside clouds just above i''th level
        , flux_propag_1(nd_profile) &
!           Temporary fluxes for propagation across layers
        , flux_propag_2(nd_profile) &
!           Temporary fluxes for propagation across layers
        , flux_propag_3(nd_profile)
!           Temporary fluxes for propagation across layers
!
!
!
!
!     The arrays flux_down and flux_up will eventually contain the total
!     fluxes, but initially they are used for the clear fluxes.
!     Note that downward fluxes refer to values just below the interface
!     and upward fluxes to values just above it.
!
!
!     Downward flux:
!
!     Region above clouds:
      DO l=1, n_profile
        flux_total(l, 2)=flux_inc_down(l)
      ENDDO
      DO i=1, n_cloud_top-1
        DO l=1, n_profile
          flux_total(l, 2*i+2)=t(l, i)*flux_total(l, 2*i) &
            +s_down(l, i)
        ENDDO
      ENDDO
!
!     Pass into the cloudy region. here, downward fluxes hold values
!     just below the level and upward fluxes the values just above it.
!     Thus the fluxes impinging on the layer are held.
      i=n_cloud_top-1
      DO l=1, n_profile
        flux_down_1(l, i)=v11(l, i)*flux_total(l, 2*i+2)
        flux_down_2(l, i)=v21(l, i)*flux_total(l, 2*i+2)
        flux_down_3(l, i)=v31(l, i)*flux_total(l, 2*i+2)
      ENDDO
!
      DO i=n_cloud_top, n_layer-1
        DO l=1, n_profile
!
!         Propagte the flux across the layer.
          flux_propag_1(l)=t(l, i)*flux_down_1(l, i-1) &
            +s_down(l, i)
          flux_propag_2(l)=t_strat(l, i)*flux_down_2(l, i-1) &
            +s_down_strat(l, i)
          flux_propag_3(l)=t_conv(l, i)*flux_down_3(l, i-1) &
            +s_down_conv(l, i)
!
!         Transfer across the interface.
          flux_down_1(l, i)=v11(l, i)*flux_propag_1(l) &
            +v12(l, i)*flux_propag_2(l) &
            +v13(l, i)*flux_propag_3(l)
          flux_down_2(l, i)=v21(l, i)*flux_propag_1(l) &
            +v22(l, i)*flux_propag_2(l) &
            +v23(l, i)*flux_propag_3(l)
          flux_down_3(l, i)=v31(l, i)*flux_propag_1(l) &
            +v32(l, i)*flux_propag_2(l) &
            +v33(l, i)*flux_propag_3(l)
!
        ENDDO
      ENDDO
!
!     Propagate across the bottom layer and form the reflected beam.
!     We do not transfer fluxes across the bottom interface, so as
!     to make the reflection consistent between regions.
      DO l=1, n_profile
!
!       Propagte the flux through the layer.
        flux_down_1(l, n_layer) &
          =t(l, n_layer)*flux_down_1(l, n_layer-1) &
          +s_down(l, n_layer)
        flux_down_2(l, n_layer) &
          =t_strat(l, n_layer)*flux_down_2(l, n_layer-1) &
          +s_down_strat(l, n_layer)
        flux_down_3(l, n_layer) &
          =t_conv(l, n_layer)*flux_down_3(l, n_layer-1) &
          +s_down_conv(l, n_layer)
!
!       Reflect from the surface.
        flux_up_1(l, n_layer) &
          =albedo_surface_diff(l)*flux_down_1(l, n_layer) &
          +source_ground_free(l)
        flux_up_2(l, i) &
          =albedo_surface_diff(l)*flux_down_2(l, n_layer) &
          +source_ground_strat(l)
        flux_up_3(l, i) &
          =albedo_surface_diff(l)*flux_down_3(l, n_layer) &
          +source_ground_conv(l)
!
!       Propagate across the bottom layer.
        flux_propag_1(l) &
          =t(l, n_layer)*flux_up_1(l, n_layer)+s_up(l, n_layer) &
          +r(l, n_layer)*flux_down_1(l, n_layer-1)
        flux_propag_2(l) &
          =t_strat(l, n_layer)*flux_up_2(l, n_layer) &
          +s_up_strat(l, n_layer) &
          +r_strat(l, n_layer)*flux_down_2(l, n_layer-1)
        flux_propag_3(l) &
          =t_conv(l, n_layer)*flux_up_3(l, n_layer) &
          +s_up_conv(l, n_layer) &
          +r_conv(l, n_layer)*flux_down_3(l, n_layer-1)
!
      ENDDO
!
!
!
!     Work back up through the column assigning the upward fluxes.
      DO i=n_layer-1, n_cloud_top, -1
        DO l=1, n_profile
!
          flux_up_1(l, i)=u11(l, i)*flux_propag_1(l) &
            +u12(l, i)*flux_propag_2(l) &
            +u13(l, i)*flux_propag_3(l)
          flux_up_2(l, i)=u21(l, i)*flux_propag_1(l) &
            +u22(l, i)*flux_propag_2(l) &
            +u23(l, i)*flux_propag_3(l)
          flux_up_3(l, i)=u31(l, i)*flux_propag_1(l) &
            +u32(l, i)*flux_propag_2(l) &
            +u33(l, i)*flux_propag_3(l)
!
          flux_propag_1(l)=t(l, i)*flux_up_1(l, i)+s_up(l, i) &
            +r(l, i)*flux_down_1(l, i-1)
          flux_propag_2(l)=t_strat(l, i)*flux_up_2(l, i) &
            +s_up_strat(l, i)+r_strat(l, i)*flux_down_2(l, i-1)
          flux_propag_3(l)=t_conv(l, i)*flux_up_3(l, i) &
            +s_up_conv(l, i)+r_conv(l, i)*flux_down_3(l, i-1)
!
        ENDDO
      ENDDO
!
!     Propagate into the cloud-free region.
      i=n_cloud_top-1
      DO l=1, n_profile
        flux_total(l, 2*i+1)=flux_propag_1(l)+flux_propag_2(l) &
          +flux_propag_3(l)
      ENDDO
!
!     Continue through the upper cloudy layers.
      DO i=n_cloud_top-1, 1, -1
        DO l=1, n_profile
          flux_total(l, 2*i-1)=t(l, i)*flux_total(l, 2*i+1) &
            +r(l, i)*flux_total(l, 2*i)+s_up(l, i)
        ENDDO
      ENDDO
!
!     Assign the total fluxes on the intermediate cloudy layers.
      DO i=n_cloud_top, n_layer
        DO l=1, n_profile
          flux_total(l, 2*i+1)=flux_up_1(l, i)+flux_up_2(l, i) &
            +flux_up_3(l, i)
          flux_total(l, 2*i+2)=flux_down_1(l, i)+flux_down_2(l, i) &
            +flux_down_3(l, i)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLVER_TRIPLE_APP_SCAT
!+ Subroutine to solve for mixed fluxes scattering without a matrix.
!
! Method:
!        Gaussian elimination in an upward direction is employed to
!       determine effective albedos for lower levels of the atmosphere.
!        This allows a downward pass of back-substitution to be carried
!        out to determine the upward and downward fluxes.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solver_triple(n_profile, n_layer, n_cloud_top &
         , t, r, s_down, s_up &
         , t_strat, r_strat, s_down_strat, s_up_strat &
         , t_conv, r_conv, s_down_conv, s_up_conv &
         , v11, v12, v13, v21, v22, v23, v31, v32, v33 &
         , u11, u12, u13, u21, u22, u23, u31, u32, u33 &
         , flux_inc_down &
         , source_ground_free, source_ground_strat &
         , source_ground_conv, albedo_surface_diff &
         , flux_total &
         , nd_profile, nd_layer, id_ct &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_ct
!           Topmost declared cloudy layer
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Topmost cloudy layer
      REAL  (RealK), Intent(IN) :: &
          t(nd_profile, nd_layer) &
!           Clear-sky transmission
        , r(nd_profile, nd_layer) &
!           Clear-sky reflection
        , s_down(nd_profile, nd_layer) &
!           Clear-sky downward source function
        , s_up(nd_profile, nd_layer) &
!           Clear-sky upward source function
        , t_strat(nd_profile, nd_layer) &
!           Stratfiform transmission
        , r_strat(nd_profile, nd_layer) &
!           Stratfiform reflection
        , s_down_strat(nd_profile, nd_layer) &
!           Downward stratfiform source function
        , s_up_strat(nd_profile, nd_layer) &
!           Upward stratfiform source function
        , t_conv(nd_profile, nd_layer) &
!           Convective transmission
        , r_conv(nd_profile, nd_layer) &
!           Convective reflection
        , s_down_conv(nd_profile, nd_layer) &
!           Downward convective source function
        , s_up_conv(nd_profile, nd_layer)
!           Upward convective source function
      REAL  (RealK), Intent(IN) :: &
          v11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v13(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v23(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v31(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v32(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v33(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient for downward radiation
      REAL  (RealK) :: &
          u11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u13(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u23(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u31(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u32(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u33(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient for upward radiation
      REAL  (RealK), Intent(IN) :: &
          flux_inc_down(nd_profile) &
!           Incident flux
        , source_ground_free(nd_profile) &
!           Source from ground (clear sky)
        , source_ground_strat(nd_profile) &
!           Source from ground (cloudy region)
        , source_ground_conv(nd_profile) &
!           Source from ground (cloudy region)
        , albedo_surface_diff(nd_profile)
!           Diffuse albedo
      REAL  (RealK), Intent(OUT) :: &
          flux_total(nd_profile, 2*nd_layer+2)
!           Total flux
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!     Effective coupling albedos and source functions:
      REAL  (RealK) :: &
          alpha11(nd_profile, nd_layer+1) &
        , alpha12(nd_profile, nd_layer+1) &
        , alpha13(nd_profile, nd_layer+1) &
        , alpha21(nd_profile, nd_layer+1) &
        , alpha22(nd_profile, nd_layer+1) &
        , alpha23(nd_profile, nd_layer+1) &
        , alpha31(nd_profile, nd_layer+1) &
        , alpha32(nd_profile, nd_layer+1) &
        , alpha33(nd_profile, nd_layer+1) &
        , g1(nd_profile, nd_layer+1) &
        , g2(nd_profile, nd_layer+1) &
        , g3(nd_profile, nd_layer+1)
!     Terms for downward propagation:
      REAL  (RealK) :: &
          gamma11(nd_profile, nd_layer) &
        , gamma12(nd_profile, nd_layer) &
        , gamma13(nd_profile, nd_layer) &
        , gamma21(nd_profile, nd_layer) &
        , gamma22(nd_profile, nd_layer) &
        , gamma23(nd_profile, nd_layer) &
        , gamma31(nd_profile, nd_layer) &
        , gamma32(nd_profile, nd_layer) &
        , gamma33(nd_profile, nd_layer) &
        , beta11_inv(nd_profile, nd_layer) &
        , beta21(nd_profile, nd_layer) &
        , beta22_inv(nd_profile, nd_layer) &
        , beta31(nd_profile, nd_layer) &
        , beta32(nd_profile, nd_layer) &
        , beta33_inv(nd_profile, nd_layer) &
        , h1(nd_profile, nd_layer) &
        , h2(nd_profile, nd_layer) &
        , h3(nd_profile, nd_layer)
!
!     Auxilairy numerical variables required only in the current layer:
      REAL  (RealK) :: &
          theta11 &
        , theta12 &
        , theta13 &
        , theta21 &
        , theta22 &
        , theta23 &
        , theta31 &
        , theta32 &
        , theta33 &
        , lambda3 &
        , lambda2 &
        , lambda1 &
        , lambda
!
!     Temporary fluxes
      REAL  (RealK) :: &
          flux_down_1(nd_profile, 0: nd_layer) &
!           Downward fluxes outside clouds just below i''th level
        , flux_down_2(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below i''th level
        , flux_down_3(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below i''th level
        , flux_up_1(nd_profile, 0: nd_layer) &
!           Upward fluxes outside clouds just above i''th level
        , flux_up_2(nd_profile, 0: nd_layer) &
!           Upward fluxes inside clouds just above i''th level
        , flux_up_3(nd_profile, 0: nd_layer)
!           Upward fluxes inside clouds just above i''th level
!
!
!
!     This routine is specific to cases of three regions and it is
!     assumed that 1 represents clear skies, 2 represents startiform
!     clouds and 3 represents convective cloud.
!
!     Initialize at the bottom of the column for upward elimination.
      DO l=1, n_profile
        alpha11(l, n_layer+1)=albedo_surface_diff(l)
        alpha12(l, n_layer+1)=0.0e+00_RealK
        alpha13(l, n_layer+1)=0.0e+00_RealK
        alpha21(l, n_layer+1)=0.0e+00_RealK
        alpha22(l, n_layer+1)=albedo_surface_diff(l)
        alpha23(l, n_layer+1)=0.0e+00_RealK
        alpha31(l, n_layer+1)=0.0e+00_RealK
        alpha32(l, n_layer+1)=0.0e+00_RealK
        alpha33(l, n_layer+1)=albedo_surface_diff(l)
        g1(l, n_layer+1)=source_ground_free(l)
        g2(l, n_layer+1)=source_ground_strat(l)
        g3(l, n_layer+1)=source_ground_conv(l)
      ENDDO
!
!     Upward elimination through the cloudy layers.
      DO i=n_layer, n_cloud_top, -1
        DO l=1, n_profile
!
          theta11=alpha11(l, i+1)*v11(l, i)+alpha12(l, i+1)*v21(l, i) &
            +alpha13(l, i+1)*v31(l, i)
          theta12=alpha11(l, i+1)*v12(l, i)+alpha12(l, i+1)*v22(l, i) &
            +alpha13(l, i+1)*v32(l, i)
          theta13=alpha11(l, i+1)*v13(l, i)+alpha12(l, i+1)*v23(l, i) &
            +alpha13(l, i+1)*v33(l, i)
          theta21=alpha21(l, i+1)*v11(l, i)+alpha22(l, i+1)*v21(l, i) &
            +alpha23(l, i+1)*v31(l, i)
          theta22=alpha21(l, i+1)*v12(l, i)+alpha22(l, i+1)*v22(l, i) &
            +alpha23(l, i+1)*v32(l, i)
          theta23=alpha21(l, i+1)*v13(l, i)+alpha22(l, i+1)*v23(l, i) &
            +alpha23(l, i+1)*v33(l, i)
          theta31=alpha31(l, i+1)*v11(l, i)+alpha32(l, i+1)*v21(l, i) &
            +alpha33(l, i+1)*v31(l, i)
          theta32=alpha31(l, i+1)*v12(l, i)+alpha32(l, i+1)*v22(l, i) &
            +alpha33(l, i+1)*v32(l, i)
          theta33=alpha31(l, i+1)*v13(l, i)+alpha32(l, i+1)*v23(l, i) &
            +alpha33(l, i+1)*v33(l, i)
          beta31(l, i)=-theta31*r(l, i)
          beta32(l, i)=-theta32*r_strat(l, i)
          beta33_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-theta33*r_conv(l, i))
          gamma31(l, i)=theta31*t(l, i)
          gamma32(l, i)=theta32*t_strat(l, i)
          gamma33(l, i)=theta33*t_conv(l, i)
          h3(l, i)=g3(l, i+1)+theta31*s_down(l, i) &
            +theta32*s_down_strat(l, i) &
            +theta33*s_down_conv(l, i)
!
          lambda3=theta23*r_conv(l, i)*beta33_inv(l, i)
          beta22_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-theta22*r_strat(l, i)+lambda3*beta32(l, i))
          beta21(l, i)=-theta21*r(l, i)+lambda3*beta31(l, i)
          gamma21(l, i)=theta21*t(l, i)+lambda3*gamma31(l, i)
          gamma22(l, i)=theta22*t_strat(l, i)+lambda3*gamma32(l, i)
          gamma23(l, i)=theta23*t_conv(l, i)+lambda3*gamma33(l, i)
          h2(l, i)=g2(l, i+1)+theta21*s_down(l, i) &
            +theta22*s_down_strat(l, i)+theta23*s_down_conv(l, i) &
            +lambda3*h3(l, i)
!
          lambda3=theta13*r_conv(l, i)*beta33_inv(l, i)
          lambda2=(theta12*r_strat(l, i)-lambda3*beta32(l, i)) &
            *beta22_inv(l, i)
          beta11_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-theta11*r(l, i)+lambda3*beta31(l, i) &
            +lambda2*beta21(l, i))
          gamma11(l, i)=theta11*t(l, i)+lambda3*gamma31(l, i) &
            +lambda2*gamma21(l, i)
          gamma12(l, i)=theta12*t_strat(l, i)+lambda3*gamma32(l, i) &
            +lambda2*gamma22(l, i)
          gamma13(l, i)=theta13*t_conv(l, i)+lambda3*gamma33(l, i) &
            +lambda2*gamma23(l, i)
          h1(l, i)=g1(l, i+1)+theta11*s_down(l, i) &
            +theta12*s_down_strat(l, i)+theta13*s_down_conv(l, i) &
            +lambda3*h3(l, i)+lambda2*h2(l, i)
!
          lambda3=u33(l, i-1)*t_conv(l, i)*beta33_inv(l, i)
          lambda2=(u32(l, i-1)*t_strat(l, i)+lambda3*beta32(l, i)) &
            *beta22_inv(l, i)
          lambda1=(u31(l, i-1)*t(l, i)+lambda3*beta31(l, i) &
            +lambda2*beta21(l, i))*beta11_inv(l, i)
          alpha31(l, i)=u31(l, i-1)*r(l, i)+lambda3*gamma31(l, i) &
            +lambda2*gamma21(l, i)+lambda1*gamma11(l, i)
          alpha32(l, i)=u32(l, i-1)*r_strat(l, i) &
            +lambda3*gamma32(l, i)+lambda2*gamma22(l, i) &
            +lambda1*gamma12(l, i)
          alpha33(l, i)=u33(l, i-1)*r_conv(l, i) &
            +lambda3*gamma33(l, i)+lambda2*gamma23(l, i) &
            +lambda1*gamma13(l, i)
          g3(l, i)=u31(l, i-1)*s_up(l, i)+u32(l, i-1)*s_up_strat(l, i) &
            +u33(l, i-1)*s_up_conv(l, i) &
            +lambda3*h3(l, i)+lambda2*h2(l, i)+lambda1*h1(l, i)
!
          lambda3=u23(l, i-1)*t_conv(l, i)*beta33_inv(l, i)
          lambda2=(u22(l, i-1)*t_strat(l, i)+lambda3*beta32(l, i)) &
            *beta22_inv(l, i)
          lambda1=(u21(l, i-1)*t(l, i)+lambda3*beta31(l, i) &
            +lambda2*beta21(l, i))*beta11_inv(l, i)
          alpha21(l, i)=u21(l, i-1)*r(l, i)+lambda3*gamma31(l, i) &
            +lambda2*gamma21(l, i)+lambda1*gamma11(l, i)
          alpha22(l, i)=u22(l, i-1)*r_strat(l, i) &
            +lambda3*gamma32(l, i)+lambda2*gamma22(l, i) &
            +lambda1*gamma12(l, i)
          alpha23(l, i)=u23(l, i-1)*r_conv(l, i) &
            +lambda3*gamma33(l, i)+lambda2*gamma23(l, i) &
            +lambda1*gamma13(l, i)
          g2(l, i)=u21(l, i-1)*s_up(l, i)+u22(l, i-1)*s_up_strat(l, i) &
            +u23(l, i-1)*s_up_conv(l, i) &
            +lambda3*h3(l, i)+lambda2*h2(l, i)+lambda1*h1(l, i)
!
          lambda3=u13(l, i-1)*t_conv(l, i)*beta33_inv(l, i)
          lambda2=(u12(l, i-1)*t_strat(l, i)+lambda3*beta32(l, i)) &
            *beta22_inv(l, i)
          lambda1=(u11(l, i-1)*t(l, i)+lambda3*beta31(l, i) &
            +lambda2*beta21(l, i))*beta11_inv(l, i)
          alpha11(l, i)=u11(l, i-1)*r(l, i)+lambda3*gamma31(l, i) &
            +lambda2*gamma21(l, i)+lambda1*gamma11(l, i)
          alpha12(l, i)=u12(l, i-1)*r_strat(l, i) &
            +lambda3*gamma32(l, i)+lambda2*gamma22(l, i) &
            +lambda1*gamma12(l, i)
          alpha13(l, i)=u13(l, i-1)*r_conv(l, i) &
            +lambda3*gamma33(l, i)+lambda2*gamma23(l, i) &
            +lambda1*gamma13(l, i)
          g1(l, i)=u11(l, i-1)*s_up(l, i)+u12(l, i-1)*s_up_strat(l, i) &
            +u13(l, i-1)*s_up_conv(l, i) &
            +lambda3*h3(l, i)+lambda2*h2(l, i)+lambda1*h1(l, i)
!
        ENDDO
      ENDDO
!
!     The layer above the cloud, if the cloud does not reach to the top
!     of the column: only one set of alphas is now needed.
!
      IF (n_cloud_top > 1) THEN
!
        i=n_cloud_top-1
        DO l=1, n_profile
!
          IF (n_cloud_top < n_layer) THEN
!           If there is no cloud in the column the V''s will not be
!           assigned so an IF-test is required.
            theta11=alpha11(l, i+1)*v11(l, i)+alpha12(l, i+1)*v21(l, i) &
              +alpha13(l, i+1)*v31(l, i)
          ELSE
            theta11=alpha11(l, i+1)
          ENDIF
!
          beta11_inv(l, i)=1.0e+00_RealK/(1.0e+00_realk-theta11*r(l, i))
          gamma11(l, i)=theta11*t(l, i)
          h1(l, i)=g1(l, i+1)+theta11*s_down(l, i)
!
          lambda=t(l, i)*beta11_inv(l, i)
          alpha11(l, i)=r(l, i)+lambda*gamma11(l, i)
          g1(l, i)=s_up(l, i)+lambda*h1(l, i)
!
        ENDDO
!
      ENDIF
!
!
!     Continue through the cloud free region: if there is no such
!     region the DO-loop will not be executed.
      DO i=n_cloud_top-2, 1, -1
        DO l=1, n_profile
!
          beta11_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-alpha11(l, i+1)*r(l, i))
          gamma11(l, i)=alpha11(l, i+1)*t(l, i)
          h1(l, i)=g1(l, i+1)+alpha11(l, i+1)*s_down(l, i)
!
          lambda1=t(l, i)*beta11_inv(l, i)
          alpha11(l, i)=r(l, i)+lambda1*gamma11(l, i)
          g1(l, i)=s_up(l, i)+lambda1*h1(l, i)
!
        ENDDO
      ENDDO
!
!
!     Initialize for downward back-substitution.
      DO l=1, n_profile
        flux_total(l, 2)=flux_inc_down(l)
      ENDDO
      IF (n_cloud_top > 1) THEN
        DO l=1, n_profile
          flux_total(l, 1)=alpha11(l, 1)*flux_total(l, 2)+g1(l, 1)
        ENDDO
      ELSE
        DO l=1, n_profile
          flux_total(l, 1)=g1(l, 1)+flux_inc_down(l) &
            *(v11(l, 0)*alpha11(l, 1)+v21(l, 0)*alpha12(l, 1) &
            + v31(l, 0)*alpha13(l, 1))
        ENDDO
      ENDIF
!
!     Sweep downward through the clear-sky region, finding the downward
!     flux at the top of the layer and the upward flux at the bottom.
      DO i=1, n_cloud_top-1
        DO l=1, n_profile
          flux_total(l, 2*i+1)=(gamma11(l, i)*flux_total(l, 2*i) &
            +h1(l, i))*beta11_inv(l, i)
          flux_total(l, 2*i+2)=t(l, i)*flux_total(l, 2*i) &
            +r(l, i)*flux_total(l, 2*i+1)+s_down(l, i)
        ENDDO
      ENDDO
!
!     Pass into the top cloudy layer. use flux_down_[1,2,3] to hold,
!     provisionally, the downward fluxes just below the top of the
!     layer, then calculate the upward fluxes at the bottom and
!     finally the downward fluxes at the bottom of the layer.
      IF (n_cloud_top <= n_layer) THEN
!       If there are no clouds n_cloud_top may be out-of-bounds for
!       these arrays so an if test is required.
        i=n_cloud_top
        DO l=1, n_profile
          flux_down_1(l, i)=v11(l, i-1)*flux_total(l, 2*i)
          flux_down_2(l, i)=v21(l, i-1)*flux_total(l, 2*i)
          flux_down_3(l, i)=v31(l, i-1)*flux_total(l, 2*i)
          flux_up_1(l, i)=(gamma11(l, i)*flux_down_1(l, i) &
            +gamma12(l, i)*flux_down_2(l, i) &
            +gamma13(l, i)*flux_down_3(l, i) &
            +h1(l, i))*beta11_inv(l, i)
          flux_up_2(l, i)=(gamma21(l, i)*flux_down_1(l, i) &
            +gamma22(l, i)*flux_down_2(l, i) &
            +gamma23(l, i)*flux_down_3(l, i)+h2(l, i) &
            -beta21(l, i)*flux_up_1(l, i))*beta22_inv(l, i)
          flux_up_3(l, i)=(gamma31(l, i)*flux_down_1(l, i) &
            +gamma32(l, i)*flux_down_2(l, i) &
            +gamma33(l, i)*flux_down_3(l, i)+h3(l, i) &
            -beta31(l, i)*flux_up_1(l, i)-beta32(l, i)*flux_up_2(l, i)) &
            *beta33_inv(l, i)
          flux_down_1(l, i)=t(l, i)*flux_down_1(l, i) &
            +r(l, i)*flux_up_1(l, i)+s_down(l, i)
          flux_down_2(l, i)=t_strat(l, i)*flux_down_2(l, i) &
            +r_strat(l, i)*flux_up_2(l, i)+s_down_strat(l, i)
          flux_down_3(l, i)=t_conv(l, i)*flux_down_3(l, i) &
            +r_conv(l, i)*flux_up_3(l, i)+s_down_conv(l, i)
        ENDDO
      ENDIF
!
!     The main loop of back-substitution. the provisional use of the
!     downward fluxes is as above.
      DO i=n_cloud_top+1, n_layer
        DO l=1, n_profile
          flux_down_1(l, i)=v11(l, i-1)*flux_down_1(l, i-1) &
            +v12(l, i-1)*flux_down_2(l, i-1) &
            +v13(l, i-1)*flux_down_3(l, i-1)
          flux_down_2(l, i)=v21(l, i-1)*flux_down_1(l, i-1) &
            +v22(l, i-1)*flux_down_2(l, i-1) &
            +v23(l, i-1)*flux_down_3(l, i-1)
          flux_down_3(l, i)=v31(l, i-1)*flux_down_1(l, i-1) &
            +v32(l, i-1)*flux_down_2(l, i-1) &
            +v33(l, i-1)*flux_down_3(l, i-1)
          flux_up_1(l, i)=(gamma11(l, i)*flux_down_1(l, i) &
            +gamma12(l, i)*flux_down_2(l, i) &
            +gamma13(l, i)*flux_down_3(l, i) &
            +h1(l, i))*beta11_inv(l, i)
          flux_up_2(l, i)=(gamma21(l, i)*flux_down_1(l, i) &
            +gamma22(l, i)*flux_down_2(l, i) &
            +gamma23(l, i)*flux_down_3(l, i)+h2(l, i) &
            -beta21(l, i)*flux_up_1(l, i))*beta22_inv(l, i)
          flux_up_3(l, i)=(gamma31(l, i)*flux_down_1(l, i) &
            +gamma32(l, i)*flux_down_2(l, i) &
            +gamma33(l, i)*flux_down_3(l, i)+h3(l, i) &
            -beta31(l, i)*flux_up_1(l, i) &
            -beta32(l, i)*flux_up_2(l, i)) &
            *beta33_inv(l, i)
          flux_down_1(l, i)=t(l, i)*flux_down_1(l, i) &
            +r(l, i)*flux_up_1(l, i)+s_down(l, i)
          flux_down_2(l, i)=t_strat(l, i)*flux_down_2(l, i) &
            +r_strat(l, i)*flux_up_2(l, i)+s_down_strat(l, i)
          flux_down_3(l, i)=t_conv(l, i)*flux_down_3(l, i) &
            +r_conv(l, i)*flux_up_3(l, i)+s_down_conv(l, i)
        ENDDO
      ENDDO
!
!
!     Calculate the overall flux.
      DO i=n_cloud_top, n_layer
        DO l=1, n_profile
          flux_total(l, 2*i+1)=flux_up_1(l, i)+flux_up_2(l, i) &
            +flux_up_3(l, i)
          flux_total(l, 2*i+2)=flux_down_1(l, i)+flux_down_2(l, i) &
            +flux_down_3(l, i)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLVER_TRIPLE
!+ Subroutine to solve for mixed fluxes scattering without a matrix.
!
! Method:
!        Gaussian elimination in an upward direction is employed to
!       determine effective albedos for lower levels of the atmosphere.
!        This allows a downward pass of back-substitution to be carried
!        out to determine the upward and downward fluxes.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                Comment
!        1.0                12-04-95        First version under RCS
!                                        (J. M. Edwards)
!       1.1             29-05-06        Modified to fix asymmetry between
!                                       stratiform and convective clouds,
!                                       and to allow shadowing
!                                       (R. J. Hogan)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE solver_triple_hogan(n_profile, n_layer, n_cloud_top &
         , t, r, s_down, s_up &
         , t_strat, r_strat, s_down_strat, s_up_strat &
         , t_conv, r_conv, s_down_conv, s_up_conv &
         , v11, v12, v13, v21, v22, v23, v31, v32, v33 &
         , u11, u12, u13, u21, u22, u23, u31, u32, u33 &
         , flux_inc_down &
         , source_ground_free, source_ground_strat &
         , source_ground_conv, albedo_surface_diff &
         , flux_total &
         , nd_profile, nd_layer, id_ct &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_ct
!           Topmost declared cloudy layer
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top
!           Topmost cloudy layer
      REAL  (RealK), Intent(IN) :: &
          t(nd_profile, nd_layer) &
!           Clear-sky transmission
        , r(nd_profile, nd_layer) &
!           Clear-sky reflection
        , s_down(nd_profile, nd_layer) &
!           Clear-sky downward source function
        , s_up(nd_profile, nd_layer) &
!           Clear-sky upward source function
        , t_strat(nd_profile, nd_layer) &
!           Stratfiform transmission
        , r_strat(nd_profile, nd_layer) &
!           Stratfiform reflection
        , s_down_strat(nd_profile, nd_layer) &
!           Downward stratfiform source function
        , s_up_strat(nd_profile, nd_layer) &
!           Upward stratfiform source function
        , t_conv(nd_profile, nd_layer) &
!           Convective transmission
        , r_conv(nd_profile, nd_layer) &
!           Convective reflection
        , s_down_conv(nd_profile, nd_layer) &
!           Downward convective source function
        , s_up_conv(nd_profile, nd_layer)
!           Upward convective source function
      REAL  (RealK), Intent(IN) :: &
          v11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v13(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v23(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v31(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v32(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for downward radiation
        , v33(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient for downward radiation
      REAL  (RealK) :: &
          u11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u13(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u23(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u31(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u32(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient for upward radiation
        , u33(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient for upward radiation
      REAL  (RealK), Intent(IN) :: &
          flux_inc_down(nd_profile) &
!           Incident flux
        , source_ground_free(nd_profile) &
!           Source from ground (clear sky)
        , source_ground_strat(nd_profile) &
!           Source from ground (cloudy region)
        , source_ground_conv(nd_profile) &
!           Source from ground (cloudy region)
        , albedo_surface_diff(nd_profile)
!           Diffuse albedo
      REAL  (RealK), Intent(OUT) :: &
          flux_total(nd_profile, 2*nd_layer+2)
!           Total flux
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!     Effective coupling albedos and source functions:
      REAL  (RealK) :: &
          alpha11(nd_profile, nd_layer+1) &
        , alpha22(nd_profile, nd_layer+1) &
        , alpha33(nd_profile, nd_layer+1) &
        , g1(nd_profile, nd_layer+1) &
        , g2(nd_profile, nd_layer+1) &
        , g3(nd_profile, nd_layer+1)
!     Terms for downward propagation:
      REAL  (RealK) :: &
          gamma11(nd_profile, nd_layer) &
        , gamma22(nd_profile, nd_layer) &
        , gamma33(nd_profile, nd_layer) &
        , beta11_inv(nd_profile, nd_layer) &
        , beta22_inv(nd_profile, nd_layer) &
        , beta33_inv(nd_profile, nd_layer) &
        , h1(nd_profile, nd_layer) &
        , h2(nd_profile, nd_layer) &
        , h3(nd_profile, nd_layer)
!
!     Auxilairy numerical variables required only in the current layer:
      REAL  (RealK) :: &
          theta11 &
        , theta22 &
        , theta33 &
        , lambda3 &
        , lambda2 &
        , lambda1 &
        , lambda
!
!     Temporary fluxes
      REAL  (RealK) :: &
          flux_down_1(nd_profile, 0: nd_layer) &
!           Downward fluxes outside clouds just below i''th level
        , flux_down_2(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below i''th level
        , flux_down_3(nd_profile, 0: nd_layer) &
!           Downward fluxes inside clouds just below i''th level
        , flux_up_1(nd_profile, 0: nd_layer) &
!           Upward fluxes outside clouds just above i''th level
        , flux_up_2(nd_profile, 0: nd_layer) &
!           Upward fluxes inside clouds just above i''th level
        , flux_up_3(nd_profile, 0: nd_layer)
!           Upward fluxes inside clouds just above i''th level
!
!
!
!     This routine is specific to cases of three regions and it is
!     assumed that 1 represents clear skies, 2 represents startiform
!     clouds and 3 represents convective cloud.
!
!     Initialize at the bottom of the column for upward elimination.
      DO l=1, n_profile
        alpha11(l, n_layer+1)=albedo_surface_diff(l)
        alpha22(l, n_layer+1)=albedo_surface_diff(l)
        alpha33(l, n_layer+1)=albedo_surface_diff(l)
        g1(l, n_layer+1)=source_ground_free(l)
        g2(l, n_layer+1)=source_ground_strat(l)
        g3(l, n_layer+1)=source_ground_conv(l)
      ENDDO
!
!     Upward elimination through the cloudy layers.
      DO i=n_layer, n_cloud_top, -1
        DO l=1, n_profile
!
          theta11=alpha11(l, i+1)*v11(l, i)+alpha22(l, i+1)*v21(l, i) &
            +alpha33(l, i+1)*v31(l, i)
          theta22=alpha11(l, i+1)*v12(l, i)+alpha22(l, i+1)*v22(l, i) &
            +alpha33(l, i+1)*v32(l, i)
          theta33=alpha11(l, i+1)*v13(l, i)+alpha22(l, i+1)*v23(l, i) &
            +alpha33(l, i+1)*v33(l, i)

          beta11_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-theta11*r(l, i))
          gamma11(l, i)=theta11*t(l, i)
          h1(l, i)=g1(l, i+1)+theta11*s_down(l, i)

          beta22_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-theta22*r_strat(l, i))
          gamma22(l, i)=theta22*t_strat(l, i)
          h2(l, i)=g2(l, i+1)+theta22*s_down_strat(l, i)

          beta33_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-theta33*r_conv(l, i))
          gamma33(l, i)=theta33*t_conv(l, i)
          h3(l, i)=g3(l, i+1)+theta33*s_down_conv(l, i)

          lambda1 = s_up(l, i)+h1(l, i)*t(l, i)*beta11_inv(l, i)
          lambda2 = s_up_strat(l, i)+h2(l, i)*t_strat(l, i) &
            *beta22_inv(l, i)
          lambda3 = s_up_conv(l, i)+h3(l, i)*t_conv(l, i) &
            *beta33_inv(l, i)

          alpha11(l, i)=r(l, i) &
            + theta11*t(l, i)*t(l, i)*beta11_inv(l, i)
          g1(l, i)=u11(l, i-1)*lambda1 &
            + u12(l, i-1)*lambda2 + u13(l, i-1)*lambda3

          alpha22(l, i)=r_strat(l, i) &
            + theta22*t_strat(l, i)*t_strat(l, i)*beta22_inv(l, i)
          g2(l, i)=u21(l, i-1)*lambda1 &
            + u22(l, i-1)*lambda2 + u23(l, i-1)*lambda3

          alpha33(l, i)=r_conv(l, i) &
            + theta33*t_conv(l, i)*t_conv(l, i)*beta33_inv(l, i)

          g3(l, i)=u31(l, i-1)*lambda1 &
            + u32(l, i-1)*lambda2 + u33(l, i-1)*lambda3

        ENDDO
      ENDDO
!
!     The layer above the cloud, if the cloud does not reach to the top
!     of the column: only one set of alphas is now needed.
!
      IF (n_cloud_top > 1) THEN
!
        i=n_cloud_top-1
        DO l=1, n_profile
!
          IF (n_cloud_top < n_layer) THEN
!           If there is no cloud in the column the V''s will not be
!           assigned so an IF-test is required.
            theta11=alpha11(l, i+1)*v11(l, i)+alpha22(l, i+1)*v21(l, i) &
               +alpha33(l, i+1)*v31(l, i)
          ELSE
            theta11=alpha11(l, i+1)
          ENDIF
!
          beta11_inv(l, i)=1.0e+00_RealK/(1.0e+00_realk-theta11*r(l, i))
          gamma11(l, i)=theta11*t(l, i)
          h1(l, i)=g1(l, i+1)+theta11*s_down(l, i)
!
          lambda=t(l, i)*beta11_inv(l, i)
          alpha11(l, i)=r(l, i)+lambda*gamma11(l, i)
          g1(l, i)=s_up(l, i)+lambda*h1(l, i)
!
        ENDDO
!
      ENDIF
!
!
!     Continue through the cloud free region: if there is no such
!     region the DO-loop will not be executed.
      DO i=n_cloud_top-2, 1, -1
        DO l=1, n_profile
!
          beta11_inv(l, i)=1.0e+00_RealK &
            /(1.0e+00_RealK-alpha11(l, i+1)*r(l, i))
          gamma11(l, i)=alpha11(l, i+1)*t(l, i)
          h1(l, i)=g1(l, i+1)+alpha11(l, i+1)*s_down(l, i)
!
          lambda1=t(l, i)*beta11_inv(l, i)
          alpha11(l, i)=r(l, i)+lambda1*gamma11(l, i)
          g1(l, i)=s_up(l, i)+lambda1*h1(l, i)
!
        ENDDO
      ENDDO
!
!
!     Initialize for downward back-substitution.
      DO l=1, n_profile
        flux_total(l, 2)=flux_inc_down(l)
      ENDDO
      IF (n_cloud_top > 1) THEN
        DO l=1, n_profile
          flux_total(l, 1)=alpha11(l, 1)*flux_total(l, 2)+g1(l, 1)
        ENDDO
      ELSE
        DO l=1, n_profile
          flux_total(l, 1)=g1(l, 1)+flux_inc_down(l) &
            *(v11(l, 0)*alpha11(l, 1)+v21(l, 0)*alpha22(l, 1) &
            + v31(l, 0)*alpha33(l, 1))
        ENDDO
      ENDIF
!
!     Sweep downward through the clear-sky region, finding the downward
!     flux at the top of the layer and the upward flux at the bottom.
      DO i=1, n_cloud_top-1
        DO l=1, n_profile
          flux_total(l, 2*i+1)=(gamma11(l, i)*flux_total(l, 2*i) &
            +h1(l, i))*beta11_inv(l, i)
          flux_total(l, 2*i+2)=t(l, i)*flux_total(l, 2*i) &
            +r(l, i)*flux_total(l, 2*i+1)+s_down(l, i)
        ENDDO
      ENDDO
!
!     Pass into the top cloudy layer. use flux_down_[1,2,3] to hold,
!     provisionally, the downward fluxes just below the top of the
!     layer, then calculate the upward fluxes at the bottom and
!     finally the downward fluxes at the bottom of the layer.
      IF (n_cloud_top <= n_layer) THEN
!       If there are no clouds n_cloud_top may be out-of-bounds for
!       these arrays so an if test is required.
        i=n_cloud_top
        DO l=1, n_profile
          flux_down_1(l, i)=v11(l, i-1)*flux_total(l, 2*i)
          flux_down_2(l, i)=v21(l, i-1)*flux_total(l, 2*i)
          flux_down_3(l, i)=v31(l, i-1)*flux_total(l, 2*i)

          flux_up_1(l, i)=(gamma11(l, i)*flux_down_1(l, i) &
            +h1(l, i))*beta11_inv(l, i)
          flux_up_2(l, i)=(gamma22(l, i)*flux_down_2(l, i) &
            +h2(l, i))*beta22_inv(l, i)
          flux_up_3(l, i)=(gamma33(l, i)*flux_down_3(l, i) &
            +h3(l, i))*beta33_inv(l, i)

          flux_down_1(l, i)=t(l, i)*flux_down_1(l, i) &
            +r(l, i)*flux_up_1(l, i)+s_down(l, i)
          flux_down_2(l, i)=t_strat(l, i)*flux_down_2(l, i) &
            +r_strat(l, i)*flux_up_2(l, i)+s_down_strat(l, i)
          flux_down_3(l, i)=t_conv(l, i)*flux_down_3(l, i) &
            +r_conv(l, i)*flux_up_3(l, i)+s_down_conv(l, i)
        ENDDO
      ENDIF
!
!     The main loop of back-substitution. the provisional use of the
!     downward fluxes is as above.
      DO i=n_cloud_top+1, n_layer
        DO l=1, n_profile
          flux_down_1(l, i)=v11(l, i-1)*flux_down_1(l, i-1) &
            +v12(l, i-1)*flux_down_2(l, i-1) &
            +v13(l, i-1)*flux_down_3(l, i-1)
          flux_down_2(l, i)=v21(l, i-1)*flux_down_1(l, i-1) &
            +v22(l, i-1)*flux_down_2(l, i-1) &
            +v23(l, i-1)*flux_down_3(l, i-1)
          flux_down_3(l, i)=v31(l, i-1)*flux_down_1(l, i-1) &
            +v32(l, i-1)*flux_down_2(l, i-1) &
            +v33(l, i-1)*flux_down_3(l, i-1)

          flux_up_1(l, i)=(gamma11(l, i)*flux_down_1(l, i) &
            +h1(l, i))*beta11_inv(l, i)
          flux_up_2(l, i)=(gamma22(l, i)*flux_down_2(l, i) &
            +h2(l, i))*beta22_inv(l, i)
          flux_up_3(l, i)=(gamma33(l, i)*flux_down_3(l, i) &
            +h3(l, i))*beta33_inv(l, i)

          flux_down_1(l, i)=t(l, i)*flux_down_1(l, i) &
            +r(l, i)*flux_up_1(l, i)+s_down(l, i)
          flux_down_2(l, i)=t_strat(l, i)*flux_down_2(l, i) &
            +r_strat(l, i)*flux_up_2(l, i)+s_down_strat(l, i)
          flux_down_3(l, i)=t_conv(l, i)*flux_down_3(l, i) &
            +r_conv(l, i)*flux_up_3(l, i)+s_down_conv(l, i)
        ENDDO
      ENDDO
!
!
!     Calculate the overall flux.
      DO i=n_cloud_top, n_layer
        DO l=1, n_profile
          flux_total(l, 2*i+1)=flux_up_1(l, i)+flux_up_2(l, i) &
            +flux_up_3(l, i)
          flux_total(l, 2*i+2)=flux_down_1(l, i)+flux_down_2(l, i) &
            +flux_down_3(l, i)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SOLVER_TRIPLE_HOGAN
!+ Subroutine to solve a set of stepped block equations.
!
! Method:
!        A set of linear equations of the stepped block form
!       is solved using Gaussian elimination with pivoting by rows
!       over a restricted range. In this application it should
!       not be necessary to consider all potential equations
!       when choosing pivots and this helps to reduce the
!       band-width of the system.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE sph_matrix_solver(n_matrix, n_step, n_block &
        , a, b &
        , x &
        , nd_matrix, nd_equation, nd_diagonal &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
!
!
      IMPLICIT NONE
!
!
!     Sizes of arrays
      INTEGER, Intent(IN) :: &
          nd_matrix &
!           Size alloacted for matrices
        , nd_equation &
!           Size allocated for equations
        , nd_diagonal
!           Size allocated for diagonals
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          n_matrix &
!           Number of matrices
        , n_step &
!           Number of steps in the matrix
        , n_block
!           Size of each block
      REAL  (RealK), Intent(INOUT) :: &
          a(nd_matrix, nd_equation, nd_diagonal) &
!           Matrices of coefficients
        , b(nd_matrix, nd_equation)
!           Righthand sides
      REAL  (RealK), Intent(OUT) :: &
           x(nd_matrix, nd_equation)
!           Solution vector
!
!
!     Local variables
      INTEGER &
          i_step &
!           Counter for steps in the matrix
        , i_phase &
!           Counter for phase of elimination or back-substitution
        , ie &
!           Number of equation
        , ic &
!           Column of the compressed matrix
        , right &
!           Rightmost column of the compressed matrix
        , row_first &
!           First row of the matrix considered in the second phase
!           of elimination
        , row_last
!           Last row of the matrix considered in the second phase
!           of elimination
      INTEGER &
          i_pivot(nd_matrix) &
!           Index of pivot
        , offset_pivot(nd_matrix)
!           Offset of the pivoting element relative to the current row
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          pivot(nd_matrix) &
!           Absolute value of the pivoting element
        , rho(nd_matrix) &
!           Scaling applied to the pivotal row in elimination
        , aabs &
!           Absolute value of the current potential pivot
        , tmp
!           Temporary variable used in swapping rows
!
!
!
!     Eliminative phase:
      i_step=1
      DO while (i_step <= n_step)
!
!
!       The elminination falls naturally into two phases given
!       the structure of the matrix.
        DO i_phase=1, 2
!
          DO i=1, n_block
!
!           Set the number of the equation for elimination
!           and its column in the reduced matrix.
            ie=n_block*(2*i_step+i_phase-3)+i
            ic=n_block*(3-i_phase)+i
            IF (i_step < n_step) THEN
              right=n_block*(8-2*i_phase)
            ELSE
              right=n_block*(6-2*i_phase)
            ENDIF
!
!           Choose the row for pivoting.
            DO l=1, n_matrix
              pivot(l)=abs(a(l, ie, ic))
              i_pivot(l)=ie
              offset_pivot(l)=0
            ENDDO
!           In the next line (and a little later), we limit the
!           range to the size of the matrix because in the last
!           layer there is no further boundary to consider.
            DO j=ie+1, min(ie+n_block*i_phase-i, 2*n_step*n_block)
              DO l=1, n_matrix
                aabs=abs(a(l, j, ic))
                IF (aabs > pivot(l)) THEN
                  pivot(l)=aabs
                  i_pivot(l)=j
                ENDIF
              ENDDO
            ENDDO
!           In the first phase we also need to consider rows
!           which will have a different offset as they involve
!           conditions on the next boundary below.
            IF (i_phase == 1) THEN
              DO j=n_block*(2*i_step-1)+1 &
                , n_block*(min(2*i_step+1, 2*n_step))
                DO l=1, n_matrix
                  aabs=abs(a(l, j, ic-2*n_block))
                  IF (aabs > pivot(l)) THEN
                    pivot(l)=aabs
                    i_pivot(l)=j
                    offset_pivot(l)=2*n_block
                  ENDIF
                ENDDO
              ENDDO
            ENDIF
!
!           Swap the rows regardlessly to allow vectorization.
            DO j=ic, right
              DO l=1, n_matrix
                tmp=a(l, ie, j)
                a(l, ie, j)=a(l, i_pivot(l), j-offset_pivot(l))
                a(l, i_pivot(l), j-offset_pivot(l))=tmp
              ENDDO
            ENDDO
            DO l=1, n_matrix
              tmp=b(l, ie)
              b(l, ie)=b(l, i_pivot(l))
              b(l, i_pivot(l))=tmp
            ENDDO
!
!           Now eliminate. In both phases we have equations dealing
!           with the same boundary as the pivoting equation, but in
!           the first phase there is also an additional elimination
!           to be performed referring to the next boundary below.
            row_first=ie+1
            IF (i_step < n_step) THEN
              row_last=ie+n_block*i_phase-i
            ELSE
              row_last=ie+n_block-i
            ENDIF
            DO j=row_first, row_last
              DO l=1, n_matrix
                rho(l)=a(l, j, ic)/a(l, ie, ic)
                b(l, j)=b(l, j)-rho(l)*b(l, ie)
              ENDDO
              DO k=ic+1, right
                DO l=1, n_matrix
                  a(l, j, k)=a(l, j, k)-rho(l)*a(l, ie, k)
                ENDDO
              ENDDO
            ENDDO
!           This is the extra elimination required during the first
!           phase.
            IF (i_phase == 1) THEN
              row_first=n_block*(2*i_step-1)+1
              IF (i_step < n_step) THEN
                row_last=n_block*(2*i_step+1)
              ELSE
                row_last=n_block*2*i_step
              ENDIF
              DO j=row_first, row_last
                DO l=1, n_matrix
                  rho(l)=a(l, j, ic-2*n_block)/a(l, ie, ic)
                  b(l, j)=b(l, j)-rho(l)*b(l, ie)
                ENDDO
                DO k=ic+1, right
                  DO l=1, n_matrix
                    a(l, j, k-2*n_block) &
                      =a(l, j, k-2*n_block)-rho(l)*a(l, ie, k)
                  ENDDO
                ENDDO
              ENDDO
            ENDIF
!
          ENDDO
        ENDDO
!
        i_step=i_step+1
!
      ENDDO
!
!
!
!     Back-subsititution:
      i_step=n_step
      DO while (i_step >= 1)
!
!
        DO i_phase=2, 1, -1
!
          IF (i_step < n_step) THEN
            right=n_block*(8-2*i_phase)
          ELSE
            right=n_block*(6-2*i_phase)
          ENDIF
!
          DO i=n_block, 1, -1
!
            ie=n_block*(2*i_step+i_phase-3)+i
            ic=(3-i_phase)*n_block+i
!
            DO l=1, n_matrix
              x(l, ie)=b(l, ie)
            ENDDO
            DO j=1, right-ic
              DO l=1, n_matrix
                x(l, ie)=x(l, ie)-a(l, ie, j+ic)*x(l, ie+j)
              ENDDO
            ENDDO
            DO l=1, n_matrix
              x(l, ie)=x(l, ie)/a(l, ie, ic)
            ENDDO
!
          ENDDO
        ENDDO
!
        i_step=i_step-1
!
!
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SPH_MATRIX_SOLVER
!+ Subroutine to solve for radiances in harmonics.
!
! Method:
!        After setting the basic properties for the radiance solver
!        a matrix is built and solved.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE sph_solver(ierr &
!                        Atmospheric sizes
        , n_profile, n_layer &
!                        Angular integration
        , ms_min, ms_max, i_truncation, ls_local_trunc &
        , cg_coeff, uplm_zero, ia_sph_mm &
        , accuracy_adaptive, euler_factor &
        , i_sph_algorithm, i_sph_mode &
!                        Spectral Region
        , isolir &
!                       Options for Equivalent Extinction
        , l_scale_solar, adjust_solar_ke &
!                        Solar Fields
        , i_direct, mu_0, uplm_sol &
!                        Infra-red Properties
        , diff_planck, flux_inc_down &
        , l_ir_source_quad, diff_planck_2 &
!                       Optical properies
        , tau, omega, phase_fnc, phase_fnc_solar &
!                        Surface Conditions
        , ls_brdf_trunc, n_brdf_basis_fnc, rho_alb &
        , f_brdf, brdf_sol, brdf_hemi &
        , d_planck_flux_surface &
!                        Levels for calculating radiances
        , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
        , n_direction, direction &
!                        Calculated Radiances or Fluxes
        , flux_direct, flux_total, radiance_mono, photolysis &
!                        Dimensions of arrays
        , nd_profile, nd_layer &
        , nd_flux_profile, nd_radiance_profile, nd_j_profile &
        , nd_max_order, nd_sph_coeff &
        , nd_brdf_basis_fnc, nd_brdf_trunc &
        , nd_red_eigensystem, nd_sph_equation, nd_sph_diagonal &
        , nd_sph_cf_weight, nd_sph_u_range &
        , nd_viewing_level, nd_direction &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE error_pcf
      USE math_cnst_ccf
      USE sph_mode_pcf
      USE sph_algorithm_pcf
      USE sph_truncation_pcf
      USE spectral_region_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_flux_profile &
!           Size allocated for profiles where fluxes are calculated
        , nd_radiance_profile &
!           Size allocated for profiles where radiances are calculated
        , nd_j_profile &
!           Size allocated for profiles where mean radiances
!           are calculated
        , nd_layer &
!           Maximum number of layers
        , nd_direction &
!           Size allowed for viewing directions
        , nd_viewing_level &
!           Size allowed for levels where the radiance is calculated
        , nd_max_order &
!           Size allowed for orders of spherical harmonics
        , nd_brdf_basis_fnc &
!           Size allowed for BRDF basis functions
        , nd_brdf_trunc &
!           Size allowed for orders of BRDFs
        , nd_sph_coeff &
!           Size allowed for spherical harmonic coefficients
        , nd_red_eigensystem &
!           Size allowed for the reduced eigensystem
        , nd_sph_equation &
!           Size allowed for spherical harmonic equations
        , nd_sph_diagonal &
!           Size allowed for diagonals of the spherical harmonic
!           matrix
        , nd_sph_cf_weight &
!           Size allowed for application of weights of the C. F.
        , nd_sph_u_range
!           Size allowed for the range of u^+|- contributing on any
!           viewing level
!
!
!     Dummy variables.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
!
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , isolir
!           Spectral region
!                        Angular integration
      INTEGER, Intent(IN) :: &
          ms_min &
!           Lowest azimuthal order calculated
        , ms_max &
!           Highest azimuthal order calculated
        , ia_sph_mm(0: nd_max_order) &
!           Address of spherical coefficient for (m, m) for each m
        , ls_local_trunc(0: nd_max_order) &
!           Orders of truncation at each azimuthal order
        , i_truncation &
!           Type of truncation used
        , i_sph_mode &
!           Mode in which the spherical solver is used
        , i_sph_algorithm
!           Algorithm used to solve the spherical system
      REAL  (RealK), Intent(IN) :: &
          cg_coeff(nd_sph_coeff) &
!           Clebsch-Gordan coefficients
        , uplm_zero(nd_sph_coeff) &
!           Values of spherical harmonics at polar angles pi/2
        , uplm_sol(nd_profile, nd_sph_coeff) &
!           Values of spherical harmonics in the solar direction
        , accuracy_adaptive &
!           Accuracy for adaptive truncation
        , euler_factor
!           Factor applied to the last polar order
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use quadratic source term
!
!                       Variables for equivalent extinction
      LOGICAL, Intent(IN) :: &
          l_scale_solar
!           Apply scaling to solar flux
      REAL  (RealK), Intent(IN) :: &
          adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment of solar beam with equivalent extinction
!
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, nd_layer) &
!           Optical depth
        , omega(nd_profile, nd_layer) &
!           Albedos of single scattering
        , phase_fnc(nd_profile, nd_layer, nd_max_order) &
!           Moments of the phase function
        , phase_fnc_solar(nd_radiance_profile, nd_layer, nd_direction) &
!           The phase function evaluated for scattering from
!           the solar beam into the viewing directions
        , diff_planck(nd_profile, nd_layer) &
!           Difference in the FLUX Planckian function
        , diff_planck_2(nd_profile, nd_layer) &
!           2x2nd differences of Planckian
        , flux_inc_down(nd_profile) &
!           Incident downward flux (in real calculations this is used
!           only in the IR where it is assumed to be Planckian, but
!           in may be used in the solar in idealized test cases)
        , mu_0(nd_profile)
!           Cosines of solar zenith angles
      REAL  (RealK), Intent(INOUT) :: &
          i_direct(nd_profile, 0: nd_layer)
!           Direct solar radiance (only the first row is set on input)
      INTEGER, Intent(IN) :: &
          ls_brdf_trunc &
!           Order of trunation of BRDFs
        , n_brdf_basis_fnc
!           Number of BRDF basis functions
      REAL  (RealK), Intent(IN) :: &
          d_planck_flux_surface(nd_profile) &
!           Differential Planckian flux from the surface
        , rho_alb(nd_profile, nd_brdf_basis_fnc) &
!           Weights of the basis functions
        , f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) &
!           Array of BRDF basis terms
        , brdf_sol(nd_profile, nd_brdf_basis_fnc, nd_direction) &
!           The BRDF evaluated for scattering from the solar
!           beam into the viewing direction
        , brdf_hemi(nd_profile, nd_brdf_basis_fnc, nd_direction)
!           The BRDF evaluated for scattering from isotropic
!           radiation into the viewing direction
!
!                       Viewing Geometry
      INTEGER, Intent(IN) :: &
          n_direction &
!           Number of viewing directions
        , n_viewing_level &
!           Number of levels where radiances are calculated
        , i_rad_layer(nd_viewing_level)
!           Layers in which radiances are calculated
      REAL  (RealK), Intent(IN) :: &
          direction(nd_radiance_profile, nd_direction, 2) &
!           Viewing directions
        , frac_rad_layer(nd_viewing_level)
!           Fractions below the tops of the layers
!
!                       Radiances calculated
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_flux_profile, 0: nd_layer) &
!           Direct Flux
        , flux_total(nd_flux_profile, 2*nd_layer+2) &
!           Total Fluxes
        , radiance_mono(nd_radiance_profile &
            , nd_viewing_level, nd_direction) &
!           Radiances
        , photolysis(nd_j_profile, nd_viewing_level)
!           Rates of photolysis
!
!
!     Local variabales.
      INTEGER &
          ms &
!           Azimuthal order
        , lsr &
!           Reduced polar order
        , n_red_eigensystem &
!           Size of the reduced eigensystem
        , n_equation &
!           Number of equations
        , i &
!           Loop variable
        , id &
!           Loop variable (directions)
        , l
!           Loop variable
      REAL  (RealK) :: &
          kappa(nd_max_order/2, nd_max_order/2) &
!           Integrals of pairs of spherical harmonics over the downward
!           hemisphere
        , cgk(nd_brdf_trunc/2+1, nd_max_order) &
!           Products of the Clebsch-Gordan coefficients and the
!           hemispheric integrals
        , up_lm(nd_profile, nd_max_order+1, nd_direction) &
!           Polar parts of spherical harmonics
        , weight_u(nd_profile, nd_viewing_level &
            , nd_sph_cf_weight, nd_sph_u_range) &
!           Weights to be applied to the vector U containing the
!           complementary functions
        , c_ylm(nd_profile, nd_viewing_level, nd_max_order+1) &
!           Coefficients in the expansion of the radiance
!           in spherical harmonics
        , a(nd_profile, nd_sph_equation, nd_sph_diagonal) &
!           Matrix on the LHS of the equation for spherical
!           harmonics
        , b(nd_profile, nd_sph_equation) &
!           RHS of matrix equation
        , upm(nd_profile, nd_sph_equation) &
!           Variables u+|-
        , azim_factor(nd_profile, nd_direction)
!           Azimuthal factors
      INTEGER &
          ls_trunc_calc &
!           Order of truncation required in calculations
        , ls_brdf_trunc_calc &
!           Order of truncation of BRDFs required in calculations
        , ls_significant
!           Maximum significant polar order
!
!     Subroutines called:
!      EXTERNAL &
!          hemi_sph_integ, cg_kappa_ms &
!        , build_sph_matrix, sph_matrix_solver
!
!
!
!     Calculate the direct radiances which are independent of the
!     azimuthal order.
      IF (isolir == IP_solar) THEN
!
        IF (l_scale_solar) THEN
          DO i=1, n_layer
            DO l=1, n_profile
              i_direct(l, i)=i_direct(l, i-1) &
                *adjust_solar_ke(l, i)*exp(-tau(l, i)/mu_0(l))
            ENDDO
          ENDDO
        ELSE
          DO i=1, n_layer
            DO l=1, n_profile
              i_direct(l, i)=i_direct(l, i-1)*exp(-tau(l, i)/mu_0(l))
            ENDDO
          ENDDO
        ENDIF
!
      ENDIF
!
!     Initialize the monochromatic radiances if they are required.
      IF (i_sph_mode == IP_sph_mode_rad) THEN
        DO id=1, n_direction
          DO i=1, n_viewing_level
            DO l=1, n_profile
              radiance_mono(l, i, id)=0.0e+00_RealK
            ENDDO
          ENDDO
        ENDDO
      ENDIF
!
!
!
!     For each non-negative azimuthal order a matrix of coefficients
!     is built and solved.
      DO ms=ms_min, ms_max
!
!       Set the order of truncation required for the calculation.
!       If an adaptive truncation is used we may not calculate all
!       the declared polar orders, though space is reserved for them
!       and is initialized (this is necessary as a subsequent call to
!       this routine with different optical properties may require a
!       different number of terms). On entry we have no estimate of the
!       number of terms required, other than the assigned truncation.
        IF (i_truncation == IP_trunc_adaptive) THEN
          IF (ms == ms_min) THEN
            ls_trunc_calc=ls_local_trunc(ms)
          ELSE
!           The polar order must exceed the azimuthal order by at least
!           one, and must give an even number of harmonics.
            ls_trunc_calc=max((ms+1), ls_significant)
            ls_trunc_calc=ls_trunc_calc+mod((ls_trunc_calc+ms+1), 2)
            ls_trunc_calc=min(ls_trunc_calc, ls_local_trunc(ms))
          ENDIF
        ELSE
          ls_trunc_calc=ls_local_trunc(ms)
        ENDIF
!
!       Azimuthal factors are required if calculating radiances.
        IF (i_sph_mode == IP_sph_mode_rad) THEN
!         The recalculation of azimuthal factors for each monochromatic
!         radiance is inefficient, but avoids the need for the storage
!         of arrays with different azimuthal orders. The equation of
!         transfer is solved only for positive azimuthal orders. Hence,
!         if the azimuthal order is 0 we add in the term, but if the
!         azimuthal order is non-zero it also represents the negative
!         order and acquires a weighting factor of 2.
          IF (ms == 0) THEN
            DO id=1, n_direction
              DO l=1, n_profile
                azim_factor(l, id)=1.0e+00_RealK
              ENDDO
            ENDDO
          ELSE
            DO id=1, n_direction
              DO l=1, n_profile
                azim_factor(l, id) &
                 =2.0e+00_RealK*cos(real(ms, realk)*direction(l, id, 2))
              ENDDO
            ENDDO
          ENDIF
!         Calculate spherical harmonics in the viewing directions.
!         A judgement about storage has been made here. It is
!         deemed acceptable to store values for a fixed azimuthal
!         order, but deemed that too much storage would be required
!         for all azmuthal orders to be held at once.
          DO id=1, n_direction
            CALL eval_uplm(ms, ls_trunc_calc &
              , n_profile, direction(1, id, 1), up_lm(1, 1, id) &
              , nd_profile)
          ENDDO
        ENDIF
!
!       Calculate integrals of products of spherical harmonics for
!       use in Marshak'''s boundary conditions. These arrays are
!       recalculated each time to save storage.
        CALL hemi_sph_integ(ls_trunc_calc, ms, uplm_zero(ia_sph_mm(ms)) &
          , kappa &
          , nd_max_order &
          )
!       Perform preliminary calculations for the BRDF: we need to check
!       that the order of truncation of BRDFs does not exceed the
!       order of calculation: it must also be even.
        ls_brdf_trunc_calc &
          =min(ls_brdf_trunc, ls_trunc_calc-mod(ls_trunc_calc, 2))
        CALL cg_kappa_ms(ms, ls_trunc_calc, ls_brdf_trunc_calc &
          , cg_coeff, kappa &
          , cgk &
          , nd_max_order, nd_brdf_trunc &
          )
!
!       Initialize the spherical harmonics at this azimuthal order.
        IF ( (i_sph_mode == IP_sph_mode_flux).OR. &
             (i_sph_algorithm == IP_sph_direct) ) THEN
          DO i=1, n_viewing_level
            DO lsr=1, ls_local_trunc(ms)+1-ms
              DO l=1, n_profile
                c_ylm(l, i, lsr)=0.0e+00_RealK
              ENDDO
            ENDDO
          ENDDO
        ENDIF
!
!       In the infra-red region differential quantities are used. The
!       incident flux will then be determined from the Plankian flux
!       (which is used for consistency with two-stream calculations)
!       by dividing by pi: we must also multiply by sqrt(4.pi) to get
!       the weighting of the zeroth spherical harmonic. Other elements
!       of the array were zeroed before.
!
        n_red_eigensystem=(ls_trunc_calc+1-ms)/2
!
        CALL build_sph_matrix(i_sph_algorithm, euler_factor &
!                       Basic sizes
          , n_profile, n_layer, ls_trunc_calc &
          , ms, n_red_eigensystem &
!                       Numerical arrays of spherical terms
          , cg_coeff(ia_sph_mm(ms)), kappa, up_lm &
!                       Solar variables
          , isolir, i_direct, mu_0, uplm_sol(1, ia_sph_mm(ms)) &
          , azim_factor &
!                       Infra-red variables
          , diff_planck, l_ir_source_quad, diff_planck_2 &
!                       Isotropic incident flux
          , flux_inc_down &
!                       Optical properties
          , tau, omega, phase_fnc &
!                       Surface Fields
          , ls_brdf_trunc_calc, n_brdf_basis_fnc, rho_alb &
          , f_brdf, brdf_sol, brdf_hemi, cgk &
          , d_planck_flux_surface &
!                       Levels where radiances are calculated
          , n_viewing_level, i_rad_layer, frac_rad_layer &
!                       Viewing Geometry
          , n_direction, direction(1, 1, 1) &
!                       Output variables
          , a, b, c_ylm, weight_u, radiance_mono &
!                       Dimensions
          , nd_profile, nd_radiance_profile &
          , nd_layer, nd_viewing_level, nd_direction &
          , nd_max_order, nd_brdf_basis_fnc, nd_brdf_trunc &
          , nd_red_eigensystem, nd_sph_equation, nd_sph_diagonal &
          , nd_sph_cf_weight, nd_sph_u_range &
          )
        IF (ierr /= i_normal) RETURN
!
!       Apply standard Gaussian elimination to obtain coefficients
!       u^+|-.
!
        n_equation=2*n_layer*n_red_eigensystem
!
        CALL sph_matrix_solver(n_profile, n_layer, n_red_eigensystem &
          , a, b &
          , upm &
          , nd_profile, nd_sph_equation, nd_sph_diagonal &
          )
!
!       Increment the radiances with the contributions from
!       the complementary function.
        CALL increment_rad_cf(n_profile &
          , n_direction, azim_factor &
          , n_viewing_level, i_rad_layer &
          , i_sph_mode, i_sph_algorithm &
          , ms, ls_trunc_calc, euler_factor &
          , isolir, mu_0, kappa, up_lm &
          , n_red_eigensystem, n_equation, weight_u, upm &
          , i_direct, c_ylm, flux_direct, flux_total &
          , radiance_mono, photolysis &
          , nd_profile, nd_flux_profile &
          , nd_radiance_profile, nd_j_profile &
          , nd_layer, nd_direction, nd_viewing_level &
          , nd_max_order, nd_sph_equation, nd_sph_cf_weight &
          , nd_sph_u_range &
          )
!
        IF (i_truncation == IP_trunc_adaptive) THEN
!
!         Reduce the polar order of truncation if higher polar orders
!         make an insignificant contribution to the radiance field.
!         At least two polar orders are required.
          ls_significant=ms+1
          DO lsr=ms+2, ls_trunc_calc+1-ms
            DO i=1, n_viewing_level
              DO l=1, n_profile
                IF (abs(c_ylm(l, i, lsr)) > accuracy_adaptive &
                  *abs(c_ylm(l, i, 1))) ls_significant=lsr+ms-1
              ENDDO
            ENDDO
          ENDDO
        ENDIF
!
      ENDDO
!
      IF ( (i_sph_algorithm == IP_sph_reduced_iter).AND. &
           (isolir == IP_solar) ) THEN
!       Add in the singly scattered solar beam using the
!       potentially higher order of truncation.
        CALL single_scat_sol(n_profile, n_layer &
          , n_direction, direction &
          , n_viewing_level, i_rad_layer, frac_rad_layer &
          , i_direct, mu_0 &
          , tau, omega, phase_fnc_solar &
          , radiance_mono &
          , nd_profile, nd_radiance_profile &
          , nd_layer, nd_direction, nd_viewing_level &
          )
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE SPH_SOLVER
!+ Subroutine to evaluate a cubic spline.
!
! Method:
!        Straightforward.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE spline_evaluate(ierr, n_data, x, y, y2 &
        , x_point, y_point)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Include header files.
!      INCLUDE 'incl/error.pcf'
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_data
!           Number of data points
      REAL  (RealK), Intent(IN) :: &
          x(n_data) &
!           Abscissae of data
        , y(n_data) &
!           Ordinates of data
        , y2(n_data) &
!           Second derivative
        , x_point
!           Point for evaluation
      REAL  (RealK), Intent(OUT) :: &
          y_point
!           Value of spline
!
!     Local arguments.
      INTEGER &
          i_low &
!           Lower limit of bracketing pair
        , i_high &
!           Upper limit of bracketing pair
        , i
!           Index of new point
      REAL  (RealK) :: &
          delta &
!           Width of interval
        , a &
!           Weight of lower point
        , b &
!           Weight of upper point
        , c
!           Temporary store
!
!
      IF (n_data == 1) THEN
!       Return the only available value.
        y_point=y(1)
      ELSE IF ( (x_point > x(n_data)).OR.(x_point < x(1)) ) THEN
!       Outside the range: return an error flag for corrective action.
        ierr=i_err_range
        RETURN
      ELSE
!       Find the bracketing points by a binary chop.
        i_low=1
        i_high=n_data
1       if ((i_high-i_low).gt.1) then
          i=(i_low+i_high)/2
        IF (x_point > x(i)) THEN
          i_low=i
        ELSE
          i_high=i
        ENDIF
          goto 1
        ENDIF
        delta=x(i_high)-x(i_low)
        a=(x(i_high)-x_point)/delta
        b=(x_point-x(i_low))/delta
        c=(delta**2/6.0_RealK)
        y_point=a*(y(i_low)+(a*a-1)*y2(i_low)*c) &
          +b*(y(i_high)+(b*b-1.0_RealK)*y2(i_high)*c)
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE SPLINE_EVALUATE
!+ Subroutine to set coefficients for a spline fit.
!
! Method:
!        The second derivatives of the cubic spline are found by solving
!        a matrix equation using natural boundary conditions.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE spline_fit(n_data, x, y, y2, u)
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Include header files.
!      INCLUDE 'incl/error.pcf'
!
!     Dummy arguments
      INTEGER, Intent(IN) :: &
          n_data
!           Number of data points
      REAL  (RealK), Intent(IN) :: &
          x(n_data) &
!           Absicissae of data
        , y(n_data)
!           Ordinates of data
      REAL  (RealK), Intent(OUT) :: &
          y2(n_data) &
!           Calculated second derivatives
        , u(n_data)
!           Temporary working variable
!
!     Local arguments.
      INTEGER &
          i
!           Loop variable
      REAL  (RealK) :: &
          sigma &
!           Temporary variable
        , rho
!           Temporary variable
!
!
!     No fit is possible with one term.
      IF (n_data == 1) RETURN
!
!     This routine is essentially tridiagonal solution of a matrix
!     equation. the starting point is the natural boundary condition.
      y2(1)=0.0_RealK
      u(1)=0.0_RealK
      DO i=2, n_data-1
        sigma=(x(i)-x(i-1))/(x(i+1)-x(i-1))
        rho=sigma*y2(i-1)+2.0_RealK
        y2(i)=(sigma-1.0_RealK)/rho
        u(i)=(6.0_RealK*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
          /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sigma*u(i-1))/rho
      ENDDO
      y2(n_data)=0.0_RealK
!
!     Backsubstitution.
      DO i=n_data-1, 1, -1
        y2(i)=y2(i)*y2(i+1)+u(i)
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE SPLINE_FIT
!+ Subroutine to calculate transmission and reflection coefficients.
!
! Method:
!         Straightforward.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! description of code:
!   fortran 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE trans_source_coeff(n_profile &
         , i_layer_first, i_layer_last &
         , isolir, l_ir_source_quad &
         , tau, sum, diff, lambda, sec_00 & !hmjb
         , gamma_up, gamma_down &
         , trans, reflect, trans_0, source_coeff &
         , nd_profile &
         , id_op_lt, id_op_lb, id_trs_lt, id_trs_lb &
         , nd_source_coeff &
         )
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE source_coeff_pointer_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , id_op_lt &
!           Topmost declared layer for optical properties
        , id_op_lb &
!           Bottom declared layer for optical properties
        , id_trs_lt &
!           Topmost declared layer for transmission coefficients
        , id_trs_lb &
!           Bottom declared layer for transmission coefficients
        , nd_source_coeff
!           Size allocated for source coefficients
!
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to consider
        , i_layer_last
!           Last layer to consider
!
!     Algorithmic control
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Quadratic source in infra-red
      INTEGER, Intent(IN) :: &
          isolir
!           Spectral region
!
!     Optical properties of the layer
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, id_op_lt: id_op_lb) &
!           Optical depths of layers
        , sum(nd_profile, id_op_lt: id_op_lb) &
!           Sum of alpha_1 and alpha_2
        , diff(nd_profile, id_op_lt: id_op_lb) &
!           Difference of alpha_1 and alpha_2
        , lambda(nd_profile, id_op_lt: id_op_lb) &
!           Lambda
        , sec_00(nd_profile, id_op_lt: id_op_lb) &
!           Secant of solar zenith angle
        , gamma_up(nd_profile, id_op_lt: id_op_lb) &
!           Basic solar coefficient for upward radiation
        , gamma_down(nd_profile, id_op_lt: id_op_lb)
!           Basic solar coefficient for downward radiation
!
!     Transmission and reflection coefficients and coefficients for
!     source terms.
      REAL  (RealK), Intent(OUT) :: &
          trans(nd_profile, id_trs_lt: id_trs_lb) &
!           Diffuse transmission coefficient
        , reflect(nd_profile, id_trs_lt: id_trs_lb) &
!           Diffuse reflection coefficient
        , trans_0(nd_profile, id_trs_lt: id_trs_lb) &
!           Direct transmission coefficient
        , source_coeff(nd_profile, id_trs_lt: id_trs_lb &
            , nd_source_coeff)
!           Source coefficients
!
!
!     Local variables
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
      REAL  (RealK) :: &
          gamma &
!           Gamma
        , exponential
!           Exponential of scaled optical depth
!
!     Variables related to the treatment of ill-conditioning
      REAL  (RealK) :: &
          eps_r &
!           The smallest real number such that 1.0-EPS_R is not 1
!           to the computer''s precision
        , sq_eps_r &
!           The square root of the above
        , tmp_inv
!           Temporary work variable
!
!
!
!     Set the tolerances used in avoiding ill-conditioning, testing
!     on any variable.
      eps_r=epsilon(exponential)
      sq_eps_r=sqrt(eps_r)
!
!     Determine the diffuse transmission and reflection coefficients.
!
!hmjb: maybe it is possible to further optimize this routine if
! we tabulate, during initialization, the values of exp().

      DO i=id_trs_lt, id_trs_lb
        DO l=1, nd_profile
          !PRINT*,' pkubota ', lambda(l, i),tau(l, i),sq_eps_r
          exponential=MAX(exp(-lambda(l, i)*tau(l, i)),eps_r)
          gamma=(sum(l, i)-lambda(l, i)) &
            /(sum(l, i)+lambda(l, i))
          tmp_inv=1.0_RealK &
            /(1.0_RealK-(exponential*gamma)**2)
          trans(l, i)=exponential*(1.0_RealK-gamma**2) &
            *tmp_inv
          reflect(l, i)=gamma*(1.0_RealK-exponential**2) &
            *tmp_inv
        ENDDO
      ENDDO
!
!
!
      IF (isolir == IP_solar) THEN
!
!       Calculate the direct transmission and the source coefficients
!       for the solar beam: in the solar case these are
!       the coefficients which will multiply the direct flux at the
!       top of the layer to give the source terms for the upward
!       diffuse flux and the total downward flux.
!
        DO i=id_trs_lt, id_trs_lb
          DO l=1, nd_profile
            trans_0(l, i)=exp(-tau(l, i)*sec_00(l, i))
            source_coeff(l, i, IP_scf_solar_up) &
              =(gamma_up(l, i)-reflect(l, i) &
              *(1.0_RealK+gamma_down(l, i))) &
              -gamma_up(l, i)*trans(l, i)*trans_0(l, i)
            source_coeff(l, i, IP_scf_solar_down)=trans_0(l, i) &
              *(1.0_RealK+gamma_down(l, i) &
              -gamma_up(l, i)*reflect(l, i)) &
              -(1.0_RealK+gamma_down(l, i))*trans(l, i)
          ENDDO
        ENDDO
!
!
      ELSE IF (isolir == IP_infra_red) THEN
!
!       In the case of infra-red radiation, the first source
!       coefficient holds the multiplier for the first difference
!       of the Planckian function across the layer, and the second
!       that for the second difference.
!
        DO i=id_trs_lt, id_trs_lb
          DO l=1, nd_profile
!
!           A tolerance is added to the numerator and the denomiator
!           to avoid ill-conditioning at small optical depths.
!






            source_coeff(l, i, IP_scf_ir_1d) &
              =((1.0_RealK-trans(l, i)+reflect(l, i)) &
              +(eps_r/(sq_eps_r+tau(l, i)))) &
              /((eps_r/(sq_eps_r+tau(l, i))) &
              +tau(l, i)*sum(l, i))

!
          ENDDO
        ENDDO
!
!
        IF (l_ir_source_quad) THEN
!
!         Quadratic correction to source function.
!         This correction is very ill-conditioned for
!         small optical depths so the asymptotic form is then used.
!
          DO i=id_trs_lt, id_trs_lb
            DO l=1, nd_profile
              IF (tau(l, i) > exp(3.3e-01_RealK*log(eps_r))) THEN
                source_coeff(l, i, IP_scf_ir_2d) &
                  =-2.0_RealK &
                  *(1.0_RealK-trans(l, i)-reflect(l, i) &
                  +sq_eps_r) &
                  /(diff(l, i)*tau(l, i)+sq_eps_r)
              ELSE
                source_coeff(l, i, IP_scf_ir_2d) &
                  =-2.0_RealK+diff(l, i)*tau(l, i)
              ENDIF
              source_coeff(l, i, IP_scf_ir_2d) &
                =-(1.0_RealK+reflect(l, i)+trans(l, i) &
                +source_coeff(l, i, IP_scf_ir_2d)) &
                /(sum(l, i)*tau(l, i)+sq_eps_r)
            ENDDO
          ENDDO
!
        ENDIF
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE TRANS_SOURCE_COEFF
!+ Subroutine to solve the two-stream equations in a triple column.
!
! Method:
!        The atmospheric column is divided into three regions
!        in each layer and the two-stream coefficients are determined
!        for each region. The equations are then solved using
!        appropriate coupling of the fluxes at the boundaries
!        of layers.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE triple_column(ierr &
!                        Atmospheric properties
         , n_profile, n_layer &
!                        Two-stream scheme
         , i_2stream &
!                        Options for solver
         , i_solver, i_scatter_method &
!                        Options for equivalent extinction
         , l_scale_solar, adjust_solar_ke &
!                        Spectral region
         , isolir &
!                        Infra-red properties
         , diff_planck &
         , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
         , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                        Conditions at surface
         , diffuse_albedo, direct_albedo, d_planck_flux_surface &
!                       Optical Properties
         , ss_prop &
!                        Cloud geometry
         , n_cloud_top &
         , n_cloud_type, frac_cloud &
         , n_region, i_region_cloud, frac_region &
         , w_free, w_cloud &
         , cloud_overlap &
!                        fluxes calculated
         , flux_direct, flux_total &
!                        flags for clear-sky calculations
         , l_clear, i_solver_clear &
!                        Clear-sky fluxes calculated
         , flux_direct_clear, flux_total_clear &
!                        Dimensions of arrays
         , nd_profile, nd_layer, nd_layer_clr, id_ct &
         , nd_max_order, nd_source_coeff &
         , nd_cloud_type, nd_region, nd_overlap_coeff &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_ss_prop
      USE def_std_io_icf
      USE error_pcf
      USE solver_pcf
      USE spectral_region_pcf
      USE scatter_method_pcf
      USE cloud_region_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , nd_layer_clr &
!           Size allocated for completely clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_cloud_type &
!           Maximum number of types of cloud
        , nd_region &
!           Maximum number of cloudy regions
        , nd_overlap_coeff
!           Maximum number of overlap coefficients
!
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Top cloudy layer
        , n_cloud_type &
!           Number of types of clouds
        , isolir &
!           Spectral region
        , i_2stream &
!           Two-stream scheme
        , i_solver &
!           Solver used
        , i_solver_clear &
!           Solver for clear-sky fluxes
        , i_scatter_method
!           Method of treating scattering
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      LOGICAL, Intent(IN) :: &
          l_clear &
!           Calculate clear-sky fluxes
        , l_scale_solar &
!           Flag to scale solar
        , l_ir_source_quad
!           Use quadratic source term
!
!                       Optical properties
      TYPE(STR_ss_prop), Intent(INOUT) :: ss_prop
!       Single scattering properties of the atmosphere
!
!     Cloud geometry:
      INTEGER, Intent(IN) :: &
          n_region &
!           Number of cloudy regions
        , i_region_cloud(nd_cloud_type)
!           Regions in which types of clouds fall
      REAL  (RealK), Intent(IN) :: &
          w_cloud(nd_profile, id_ct: nd_layer) &
!           Cloudy fractions in each layer
        , w_free(nd_profile, id_ct: nd_layer) &
!           Clear sky fractions in each layer
        , frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of different types of cloud
        , cloud_overlap(nd_profile, id_ct-1: nd_layer &
            , nd_overlap_coeff) &
!           Energy transfer coefficients
        , frac_region(nd_profile, id_ct: nd_layer, nd_region)
!           Fractions of total cloud occupied by each region
      REAL  (RealK), Intent(IN) :: &
          sec_00(nd_profile, nd_layer) &
!           Secant of solar zenith angle
        , diffuse_albedo(nd_profile) &
!           Diffuse albedo
        , direct_albedo(nd_profile) &
!           Direct albedo
        , flux_inc_down(nd_profile) &
!           Incident total flux
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , diff_planck(nd_profile, nd_layer) &
!           Change in Planckian function
        , d_planck_flux_surface(nd_profile) &
!           Difference in Planckian fluxes between the surface
!           and the air above
        , adjust_solar_ke(nd_profile, nd_layer) &
!           Adjustment of solar beam with equivalent extinction
        , diff_planck_2(nd_profile, nd_layer)
!             2x2nd difference of Planckian
!
!     Fluxes calculated
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Direct flux
        , flux_total(nd_profile, 2*nd_layer+2) &
!           Long flux vector
        , flux_direct_clear(nd_profile, 0: nd_layer) &
!           Clear direct flux
        , flux_total_clear(nd_profile, 2*nd_layer+2)
!           Clear total flux
!
!
!
!     Local variabales.
      INTEGER &
          n_source_coeff &
!           Number of source coefficients
        , i &
!           Loop variable
        , l &
!           Loop variable
        , k &
!           Loop variable
        , n_top
!           Top-most layer for calculation
!
!
!     Clear-sky coefficients:
      REAL  (RealK) :: &
          trans(nd_profile, nd_layer, nd_region) &
!           Transmission coefficients
        , reflect(nd_profile, nd_layer, nd_region) &
!           Reflection coefficients
        , trans_0(nd_profile, nd_layer, nd_region) &
!           Direct transmission coefficients
        , source_coeff(nd_profile, nd_layer &
            , nd_source_coeff, nd_region) &
!           Source coefficients
        , s_down(nd_profile, nd_layer, nd_region) &
!           Free downward source
        , s_up(nd_profile, nd_layer, nd_region) &
!           Free upward source
        , s_down_clear(nd_profile, nd_layer) &
!           Clear downward source
        , s_up_clear(nd_profile, nd_layer)
!           Clear upward source
!
!     Source functions at the ground
      REAL  (RealK) :: &
          source_flux_ground(nd_profile, nd_region) &
!           Source of flux from ground
        , flux_direct_ground(nd_profile, nd_region)
!           Direct flux at ground in each region
!
!
!!     Functions called:
!      INTEGER &
!          set_n_source_coeff
!!           Function to set number of source coefficients
!!
!!     Subroutines called:
!      EXTERNAL &
!          two_coeff_region, two_coeff_region_fast_lw &
!        , ir_source, triple_solar_source &
!        , solver_triple, solver_triple_app_scat &
!        , clear_supplement
!
!
!
!     Set the number of source coefficients for the approximation
      n_source_coeff=set_n_source_coeff(isolir, l_ir_source_quad)
!
!
      IF (i_scatter_method == IP_scatter_full) THEN
        CALL two_coeff_region(ierr &
          , n_profile, n_layer, n_cloud_top &
          , i_2stream, l_ir_source_quad, n_source_coeff &
          , n_cloud_type, frac_cloud &
          , n_region, i_region_cloud, frac_region &
          , ss_prop%phase_fnc_clr, ss_prop%omega_clr, ss_prop%tau_clr &
          , ss_prop%phase_fnc, ss_prop%omega, ss_prop%tau &
          , isolir, sec_00 & !hmjb
          , trans, reflect, trans_0, source_coeff &
          , nd_profile, nd_layer, nd_layer_clr, id_ct &
          , nd_max_order, nd_source_coeff &
          , nd_cloud_type, nd_region &
          )
      ELSE IF (i_scatter_method == IP_no_scatter_abs) THEN
        CALL two_coeff_region_fast_lw(ierr &
          , n_profile, n_layer, n_cloud_top &
          , l_ir_source_quad, n_source_coeff &
          , n_cloud_type, frac_cloud &
          , n_region, i_region_cloud, frac_region &
          , ss_prop%tau_clr, ss_prop%tau &
          , isolir &
          , trans, reflect, source_coeff &
          , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_source_coeff &
          , nd_cloud_type, nd_region &
          )
      ENDIF
      IF (ierr /= i_normal) RETURN
!
!
      IF (isolir == IP_infra_red) THEN
!
        DO k=1, n_region
          IF (k == IP_region_clear) THEN
            n_top=1
          ELSE
            n_top=n_cloud_top
          ENDIF
!
          CALL ir_source(n_profile, n_top, n_layer &
            , source_coeff(1, 1, 1, k), diff_planck &
            , l_ir_source_quad, diff_planck_2 &
            , s_down(1, 1, k), s_up(1, 1, k) &
            , nd_profile, nd_layer, nd_source_coeff &
            )
        ENDDO
!
!
!       Weight the source functions by the area fractions, but
!       save the clear-sky fractions for diagnostic use if
!       required.
        IF (l_clear) THEN
!CDIR COLLAPSE
          DO i=1, nd_layer
            DO l=1, nd_profile
              s_down_clear(l, i)=s_down(l, i, IP_region_clear)
              s_up_clear(l, i)=s_up(l, i, IP_region_clear)
            ENDDO
          ENDDO
        ENDIF
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            s_down(l, i, IP_region_clear) &
              =w_free(l, i)*s_down(l, i, IP_region_clear)
            s_up(l, i, IP_region_clear) &
              =w_free(l, i)*s_up(l, i, IP_region_clear)
            s_down(l, i, IP_region_strat) &
              =w_cloud(l, i) &
              *frac_region(l, i, IP_region_strat) &
              *s_down(l, i, IP_region_strat)
            s_up(l, i, IP_region_strat) &
              =w_cloud(l, i) &
              *frac_region(l, i, IP_region_strat) &
              *s_up(l, i, IP_region_strat)
            s_down(l, i, IP_region_conv) &
              =w_cloud(l, i) &
              *frac_region(l, i, IP_region_conv) &
              *s_down(l, i, IP_region_conv)
            s_up(l, i, IP_region_conv) &
              =w_cloud(l, i) &
              *frac_region(l, i, IP_region_conv) &
              *s_up(l, i, IP_region_conv)
          ENDDO
        ENDDO
!
      ENDIF
!
!
!     Calculate the appropriate source terms for the solar: cloudy
!     and clear properties are both needed here.
!
      IF (isolir == IP_solar) THEN
!
        CALL triple_solar_source(n_profile, n_layer, n_cloud_top &
          , n_region, flux_inc_direct &
          , l_scale_solar, adjust_solar_ke &
          , trans_0, source_coeff &
          , cloud_overlap(1, id_ct-1, 1) &
          , cloud_overlap(1, id_ct-1, 2) &
          , cloud_overlap(1, id_ct-1, 3) &
          , cloud_overlap(1, id_ct-1, 4) &
          , cloud_overlap(1, id_ct-1, 5) &
          , cloud_overlap(1, id_ct-1, 6) &
          , cloud_overlap(1, id_ct-1, 7) &
          , cloud_overlap(1, id_ct-1, 8) &
          , cloud_overlap(1, id_ct-1, 9) &
          , flux_direct, flux_direct_ground &
          , s_up, s_down &
          , nd_profile, nd_layer, id_ct, nd_source_coeff, nd_region &
          )
      ENDIF
!
!       Set the partitioned source functions at the ground.
        IF (isolir == IP_solar) THEN
          DO l=1, n_profile
            source_flux_ground(l, IP_region_clear) &
              =(direct_albedo(l)-diffuse_albedo(l)) &
              *flux_direct_ground(l, IP_region_clear)
            source_flux_ground(l, IP_region_strat) &
              =(direct_albedo(l)-diffuse_albedo(l)) &
              *flux_direct_ground(l, IP_region_strat)
            source_flux_ground(l, IP_region_conv) &
              =(direct_albedo(l)-diffuse_albedo(l)) &
              *flux_direct_ground(l, IP_region_conv)
          ENDDO
        ELSE
          DO l=1, n_profile
            source_flux_ground(l, IP_region_clear) &
              =cloud_overlap(l, n_layer, 10) &
              *(1.0_RealK-diffuse_albedo(l)) &
              *d_planck_flux_surface(l)
            source_flux_ground(l, IP_region_strat) &
              =cloud_overlap(l, n_layer, 13) &
              *(1.0_RealK-diffuse_albedo(l)) &
              *d_planck_flux_surface(l)
            source_flux_ground(l, IP_region_conv) &
              =cloud_overlap(l, n_layer, 16) &
              *(1.0_RealK-diffuse_albedo(l)) &
              *d_planck_flux_surface(l)
          ENDDO
        ENDIF
!
!
!
      SELECT CASE (i_solver)

      CASE (IP_solver_triple)
!
        CALL solver_triple(n_profile, n_layer, n_cloud_top &
          , trans(1, 1, IP_region_clear) &
          , reflect(1, 1, IP_region_clear) &
          , s_down(1, 1, IP_region_clear) &
          , s_up(1, 1, IP_region_clear) &
          , trans(1, 1, IP_region_strat) &
          , reflect(1, 1, IP_region_strat) &
          , s_down(1, 1, IP_region_strat) &
          , s_up(1, 1, IP_region_strat) &
          , trans(1, 1, IP_region_conv) &
          , reflect(1, 1, IP_region_conv) &
          , s_down(1, 1, IP_region_conv) &
          , s_up(1, 1, IP_region_conv) &
          , cloud_overlap(1, id_ct-1, 1) &
          , cloud_overlap(1, id_ct-1, 2) &
          , cloud_overlap(1, id_ct-1, 3) &
          , cloud_overlap(1, id_ct-1, 4) &
          , cloud_overlap(1, id_ct-1, 5) &
          , cloud_overlap(1, id_ct-1, 6) &
          , cloud_overlap(1, id_ct-1, 7) &
          , cloud_overlap(1, id_ct-1, 8) &
          , cloud_overlap(1, id_ct-1, 9) &
          , cloud_overlap(1, id_ct-1, 10) &
          , cloud_overlap(1, id_ct-1, 11) &
          , cloud_overlap(1, id_ct-1, 12) &
          , cloud_overlap(1, id_ct-1, 13) &
          , cloud_overlap(1, id_ct-1, 14) &
          , cloud_overlap(1, id_ct-1, 15) &
          , cloud_overlap(1, id_ct-1, 16) &
          , cloud_overlap(1, id_ct-1, 17) &
          , cloud_overlap(1, id_ct-1, 18) &
          , flux_inc_down &
          , source_flux_ground(1, IP_region_clear) &
          , source_flux_ground(1, IP_region_strat) &
          , source_flux_ground(1, IP_region_conv) &
          , diffuse_albedo &
          , flux_total &
          , nd_profile, nd_layer, id_ct &
          )
!
      CASE (IP_solver_triple_hogan)
!
        CALL solver_triple_hogan(n_profile, n_layer, n_cloud_top &
          , trans(1, 1, IP_region_clear) &
          , reflect(1, 1, IP_region_clear) &
          , s_down(1, 1, IP_region_clear) &
          , s_up(1, 1, IP_region_clear) &
          , trans(1, 1, IP_region_strat) &
          , reflect(1, 1, IP_region_strat) &
          , s_down(1, 1, IP_region_strat) &
          , s_up(1, 1, IP_region_strat) &
          , trans(1, 1, IP_region_conv) &
          , reflect(1, 1, IP_region_conv) &
          , s_down(1, 1, IP_region_conv) &
          , s_up(1, 1, IP_region_conv) &
          , cloud_overlap(1, id_ct-1, 1) &
          , cloud_overlap(1, id_ct-1, 2) &
          , cloud_overlap(1, id_ct-1, 3) &
          , cloud_overlap(1, id_ct-1, 4) &
          , cloud_overlap(1, id_ct-1, 5) &
          , cloud_overlap(1, id_ct-1, 6) &
          , cloud_overlap(1, id_ct-1, 7) &
          , cloud_overlap(1, id_ct-1, 8) &
          , cloud_overlap(1, id_ct-1, 9) &
          , cloud_overlap(1, id_ct-1, 10) &
          , cloud_overlap(1, id_ct-1, 11) &
          , cloud_overlap(1, id_ct-1, 12) &
          , cloud_overlap(1, id_ct-1, 13) &
          , cloud_overlap(1, id_ct-1, 14) &
          , cloud_overlap(1, id_ct-1, 15) &
          , cloud_overlap(1, id_ct-1, 16) &
          , cloud_overlap(1, id_ct-1, 17) &
          , cloud_overlap(1, id_ct-1, 18) &
          , flux_inc_down &
          , source_flux_ground(1, IP_region_clear) &
          , source_flux_ground(1, IP_region_strat) &
          , source_flux_ground(1, IP_region_conv) &
          , diffuse_albedo &
          , flux_total &
          , nd_profile, nd_layer, id_ct &
          )
!
      CASE (IP_solver_triple_app_scat)
!
        CALL solver_triple_app_scat(n_profile, n_layer, n_cloud_top &
          , trans(1, 1, IP_region_clear) &
          , reflect(1, 1, IP_region_clear) &
          , s_down(1, 1, IP_region_clear) &
          , s_up(1, 1, IP_region_clear) &
          , trans(1, 1, IP_region_strat) &
          , reflect(1, 1, IP_region_strat) &
          , s_down(1, 1, IP_region_strat) &
          , s_up(1, 1, IP_region_strat) &
          , trans(1, 1, IP_region_conv) &
          , reflect(1, 1, IP_region_conv) &
          , s_down(1, 1, IP_region_conv) &
          , s_up(1, 1, IP_region_conv) &
          , cloud_overlap(1, id_ct-1, 1) &
          , cloud_overlap(1, id_ct-1, 2) &
          , cloud_overlap(1, id_ct-1, 3) &
          , cloud_overlap(1, id_ct-1, 4) &
          , cloud_overlap(1, id_ct-1, 5) &
          , cloud_overlap(1, id_ct-1, 6) &
          , cloud_overlap(1, id_ct-1, 7) &
          , cloud_overlap(1, id_ct-1, 8) &
          , cloud_overlap(1, id_ct-1, 9) &
          , cloud_overlap(1, id_ct-1, 10) &
          , cloud_overlap(1, id_ct-1, 11) &
          , cloud_overlap(1, id_ct-1, 12) &
          , cloud_overlap(1, id_ct-1, 13) &
          , cloud_overlap(1, id_ct-1, 14) &
          , cloud_overlap(1, id_ct-1, 15) &
          , cloud_overlap(1, id_ct-1, 16) &
          , cloud_overlap(1, id_ct-1, 17) &
          , cloud_overlap(1, id_ct-1, 18) &
          , flux_inc_down &
          , source_flux_ground(1, IP_region_clear) &
          , source_flux_ground(1, IP_region_strat) &
          , source_flux_ground(1, IP_region_conv) &
          , diffuse_albedo &
          , flux_total &
          , nd_profile, nd_layer, id_ct &
          )
!
      CASE DEFAULT
!
        WRITE(iu_err, '(/a)') &
          '*** Error: The solver specified is not valid here.'
        ierr=i_err_fatal
        RETURN
!
      END SELECT
!
!
!
      IF (l_clear) THEN
!
        CALL clear_supplement(ierr, n_profile, n_layer, i_solver_clear &
          , trans(1, 1, IP_region_clear) &
          , reflect(1, 1, IP_region_clear) &
          , trans_0(1, 1, IP_region_clear) &
          , source_coeff(1, 1, 1, IP_region_clear) &
          , isolir, flux_inc_direct, flux_inc_down &
          , s_down_clear, s_up_clear &
          , diffuse_albedo, direct_albedo &
          , d_planck_flux_surface &
          , l_scale_solar, adjust_solar_ke &
          , flux_direct_clear, flux_total_clear &
          , nd_profile, nd_layer, nd_source_coeff &
          )
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE TRIPLE_COLUMN
!+ Subroutine to set the solar solar terms in a triple column.
!
! Method:
!        The direct beam is calculated by propagating down through
!        the column. These direct fluxes are used to define the
!        source terms in each layer.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE triple_solar_source(n_profile, n_layer, n_cloud_top &
         , n_region, flux_inc_direct &
         , l_scale_solar, adjust_solar_ke &
         , trans_0, source_coeff &
         , v11, v12, v13, v21, v22, v23, v31, v32, v33 &
         , flux_direct &
         , flux_direct_ground &
         , s_up, s_down &
         , nd_profile, nd_layer, id_ct, nd_source_coeff, nd_region &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE source_coeff_pointer_pcf
      USE cloud_region_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_region
!           Maximum number of cloudy regions
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Top cloudy layer
        , n_region
!           Number of cloudy regions
!
!     Special arrays for equivalent extinction:
      LOGICAL, Intent(IN) :: &
          l_scale_solar
!           Scaling applied to solar flux
      REAL  (RealK), Intent(IN) :: &
          adjust_solar_ke(nd_profile, nd_layer)
!           Adjustment to solar fluxes with equivalent extinction
!
      REAL  (RealK), Intent(IN) :: &
          flux_inc_direct(nd_profile)
!           Incident direct solar flux
!
!     Optical properties:
      REAL  (RealK), Intent(IN) :: &
          trans_0(nd_profile, nd_layer, nd_region) &
!           Direct transmission
        , source_coeff(nd_profile, nd_layer &
          , nd_source_coeff, nd_region)
!           Source coefficients
!
!     Energy transfer coefficients:
      REAL  (RealK), Intent(IN) :: &
          v11(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v12(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v13(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v21(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v22(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v23(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v31(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v32(nd_profile, id_ct-1: nd_layer) &
!           Energy transfer coefficient
        , v33(nd_profile, id_ct-1: nd_layer)
!           Energy transfer coefficient
!
!     Calculated direct flux and source terms:
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Overall direct flux
        , flux_direct_ground(nd_profile, nd_region) &
!           Direct fluxes at ground beneath each region
        , s_up(nd_profile, nd_layer, nd_region) &
!           Upward source functions
        , s_down(nd_profile, nd_layer, nd_region)
!           Downward source functions
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l &
!           Loop variable
        , k
!           Loop variable
!
      REAL  (RealK) :: &
          solar_top(nd_profile, 0:nd_layer, nd_region) &
!           Solar fluxes at top of layer
        , solar_base(nd_profile, 0:nd_layer, nd_region)
!           Solar fluxes at base of layer
!
!
!     The clear and cloudy direct fluxes are calculated separately
!     and added together to form the total direct flux.
!
!     Set incident fluxes.
      DO l=1, n_profile
        flux_direct(l, 0)=flux_inc_direct(l)
      ENDDO
!
!     With equivalent extinction the direct solar flux must be
!     corrected.
!
!hmjb: SINCE WE ASSUME N_CLOUD_TOP == 1, THIS IS NEVER DONE
!
!
!
!     Clear and cloudy region.
!     Initialize partial fluxes:
      DO l=1, n_profile
        solar_base(l, 0, IP_region_clear)=flux_direct(l, 0)
        solar_base(l, 0, IP_region_strat)=0.0e+00_RealK
        solar_base(l, 0, IP_region_conv)=0.0e+00_RealK
      ENDDO
!
!
      DO i=1, nd_layer
!
!       Transfer fluxes across the interface.
!
        DO l=1, nd_profile
          solar_top(l, i, IP_region_clear) &
            =v11(l, i-1)*solar_base(l, i-1, IP_region_clear) &
            +v12(l, i-1)*solar_base(l, i-1, IP_region_strat) &
            +v13(l, i-1)*solar_base(l, i-1, IP_region_conv)
          solar_top(l, i, IP_region_strat) &
            =v21(l, i-1)*solar_base(l, i-1, IP_region_clear) &
            +v22(l, i-1)*solar_base(l, i-1, IP_region_strat) &
            +v23(l, i-1)*solar_base(l, i-1, IP_region_conv)
          solar_top(l, i, IP_region_conv)  &
            =v31(l, i-1)*solar_base(l, i-1, IP_region_clear) &
            +v32(l, i-1)*solar_base(l, i-1, IP_region_strat) &
            +v33(l, i-1)*solar_base(l, i-1, IP_region_conv)
        ENDDO
!
!
!       Propagate the fluxes through the layer:
!
        IF (l_scale_solar) THEN
!
          DO k=1, n_region
            DO l=1, nd_profile
              solar_base(l, i, k) &
                =solar_top(l, i, k) &
                *trans_0(l, i, k)*adjust_solar_ke(l, i)
            ENDDO
          ENDDO
!
        ELSE
!
          DO k=1, n_region
            DO l=1, nd_profile
              solar_base(l, i, k)=solar_top(l, i, k) &
                *trans_0(l, i, k)
            ENDDO
          ENDDO
!
        ENDIF
      ENDDO

      IF (l_scale_solar) THEN
!CDIR COLLAPSE
        DO k=1, n_region
          DO i=1, nd_layer
            DO l=1, nd_profile
              s_up(l, i, k) &
                =source_coeff(l, i, IP_scf_solar_up, k) &
                *solar_top(l, i, k)
              s_down(l, i, k) &
                =(source_coeff(l, i, IP_scf_solar_down, k) &
                -trans_0(l, i, k))*solar_top(l, i, k) &
                +solar_base(l, i, k)
            ENDDO
          ENDDO
        ENDDO
      ELSE
!CDIR COLLAPSE
        DO k=1, n_region
          DO i=1, nd_layer
            DO l=1, nd_profile
              s_up(l, i, k) &
                =source_coeff(l, i, IP_scf_solar_up, k) &
                *solar_top(l, i, k)
              s_down(l, i, k) &
                =source_coeff(l, i, IP_scf_solar_down, k) &
                *solar_top(l, i, k)
            ENDDO
          ENDDO
        ENDDO
      ENDIF

!
!       Calculate the total direct flux.
!

!CDIR COLLAPSE
      DO i=1, nd_layer
        DO l=1, nd_profile
          flux_direct(l, i)=solar_base(l, i, IP_region_clear) &
            +solar_base(l, i, IP_region_strat) &
            +solar_base(l, i, IP_region_conv)
        ENDDO
!
      ENDDO
!
!     Pass the last value at the base of the cloud out.
      DO k=1, n_region
        DO l=1, nd_profile
          flux_direct_ground(l, k)=solar_base(l, nd_layer, k)
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE TRIPLE_SOLAR_SOURCE
!+ Subroutine to calculate basic coefficients in two-stream equations.
!
! Method:
!        Depending on the two-stream equations employed, the
!        appropriate coefficients for the fluxes are calculated.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE two_coeff_basic(ierr &
         , n_profile, i_layer_first, i_layer_last &
         , i_2stream &
         , asymmetry, omega &
         , sum, diff &
         , nd_profile, id_lt, id_lb &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE diff_elsasser_ccf
      USE two_stream_scheme_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , id_lt &
!           Topmost declared layer
        , id_lb
!           Bottom declared layer
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to consider
        , i_layer_last &
!           Last layer to consider
        , i_2stream
!           Two stream scheme
!
!     Optical properties of layer:
      REAL  (RealK), Intent(IN) :: &
          asymmetry(nd_profile, id_lt: id_lb) &
!           Asymmetry factor
        , omega(nd_profile, id_lt: id_lb)
!           Albedo of single scattering
!
!
!     coefficients in the two-stream equations:
      REAL  (RealK), Intent(OUT) :: &
          sum(nd_profile, id_lt: id_lb) &
!           Sum of alpha_1 and alpha_2
        , diff(nd_profile, id_lt: id_lb)
!           Difference of alpha_1 and alpha_2
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
      REAL  (RealK) :: &
          root_3
!           Square root of 3
!
!
      parameter( &
          root_3=1.7320508075688772e+00_RealK &
        )
!
!
!
!
      IF (i_2stream == IP_eddington) THEN
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            sum(l, i)=1.5e+00_RealK*(1.0e+00_realk &
              -omega(l, i)*asymmetry(l, i))
            diff(l, i)=2.0e+00_RealK*(1.0e+00_realk-omega(l, i))
          ENDDO
        ENDDO
!
      ELSE IF (i_2stream == IP_elsasser) THEN
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            sum(l, i)=elsasser_factor &
              -1.5e+00_RealK*omega(l, i)*asymmetry(l, i)
            diff(l, i)=elsasser_factor*(1.0e+00_RealK-omega(l, i))
          ENDDO
        ENDDO
!
      ELSE IF (i_2stream == IP_discrete_ord) THEN
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            sum(l, i)=root_3*(1.0e+00_RealK &
              -omega(l, i)*asymmetry(l, i))
            diff(l, i)=root_3*(1.0e+00_RealK-omega(l, i))
          ENDDO
        ENDDO
!
      ELSE IF (i_2stream == IP_pifm85) THEN
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            sum(l, i)=2.0e+00_RealK &
              -1.5e+00_RealK*omega(l, i)*asymmetry(l, i)
            diff(l, i)=2.0e+00_RealK*(1.0e+00_realk-omega(l, i))
          ENDDO
        ENDDO
!
      ELSE IF (i_2stream == IP_2s_test) THEN
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            sum(l, i)=1.5e+00_RealK &
              -1.5e+00_RealK*omega(l, i)*asymmetry(l, i)
            diff(l, i)=1.5e+00_RealK*(1.0e+00_realk-omega(l, i))
          ENDDO
        ENDDO
!
      ELSE IF (i_2stream == IP_hemi_mean) THEN
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            sum(l, i)=2.0e+00_RealK &
              *(1.0e+00_RealK-omega(l, i)*asymmetry(l, i))
            diff(l, i)=2.0e+00_RealK*(1.0e+00_realk-omega(l, i))
          ENDDO
        ENDDO
!
      ELSE IF (i_2stream == IP_pifm80) THEN
        DO i=id_lt, id_lb
          DO l=1, nd_profile
            sum(l, i)=2.0e+00_RealK &
              -1.5e+00_RealK*omega(l, i)*asymmetry(l, i) &
              -0.5e+00_RealK*omega(l, i)
            diff(l, i)=2.0e+00_RealK*(1.0e+00_realk-omega(l, i))
          ENDDO
        ENDDO
!
      ELSE IF (i_2stream == IP_ifm) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: The improved flux mathod has ' &
          //'not been implemented.'
        ierr=i_err_fatal
        RETURN
!
      ELSE IF (i_2stream == IP_zdk_flux) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: Zdunkowski''s flux method has ' &
          //'not been implemented.'
        ierr=i_err_fatal
        RETURN
!
      ELSE IF (i_2stream == IP_krschg_flux) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: Kerschgen''s flux method has ' &
          //'not been implemented.'
        ierr=i_err_fatal
        RETURN
!
      ELSE IF (i_2stream == IP_coakley_chylek_1) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: Coakley and Chylek''s first method has ' &
          //'not been implemented.'
        ierr=i_err_fatal
        RETURN
!
      ELSE IF (i_2stream == IP_coakley_chylek_2) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: Coakley and Chylek''s second method has ' &
          //'not been implemented.'
        ierr=i_err_fatal
        RETURN
!
      ELSE IF (i_2stream == IP_meador_weaver) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: Meador and Weaver''s method has ' &
          //'not been implemented.'
        ierr=i_err_fatal
        RETURN
!
      ELSE
        WRITE(iu_err, '(/a, /a)') &
          '*** Error: An unrecognized value has been specified ' &
          //'to define the two-stream scheme.'
        ierr=i_err_fatal
        RETURN
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE TWO_COEFF_BASIC
!+ Subroutine to calculate cloudy two-stream coefficients.
!
! Method:
!        The coeffients for each type of cloud are determined and
!        averaged.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
!DD+ -------------------------------------------------------------------
! Compiler directives for specific computer systems:
!
! Indirect addressing will inhibit vectorization, but here it is safe
! because all points are independent.
!
! Fujistu VPP700:
!OCL NOVREC
!
! Cray vector machines:
!cfpp$ nodepchk r
!
!DD- -------------------------------------------------------------------
   
      SUBROUTINE two_coeff_cloud(ierr &
         , n_profile, i_layer_first, i_layer_last &
         , i_2stream, l_ir_source_quad, n_source_coeff &
         , n_cloud_type, frac_cloud &
         , phase_fnc_cloud, omega_cloud, tau_cloud &
         , isolir, sec_00 & !hmjb
         , trans_cloud, reflect_cloud, trans_0_cloud &
         , source_coeff_cloud &
         , nd_profile, nd_layer, id_ct, nd_max_order &
         , nd_source_coeff, nd_cloud_type &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , id_ct &
!           Topmost declared potentially cloudy layer
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_cloud_type
!           Maximum number of types of cloud
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to consider
        , i_layer_last &
!           Last layer to consider
        , isolir &
!           Spectral region
        , n_cloud_type &
!           Number of types of clouds
        , i_2stream &
!           Two stream scheme
        , n_source_coeff
!           Number of source coefficients
!
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source in the infra-red
!
!     Optical properties of layer:
      REAL  (RealK), Intent(IN) :: &
          frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of different types of clouds
        , phase_fnc_cloud(nd_profile, id_ct: nd_layer &
            , nd_max_order, nd_cloud_type) &
!           Phase functions
        , omega_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Albedo of single scattering
        , tau_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!           Optical depth
!
!     Solar beam
      REAL  (RealK), Intent(IN) :: &
          sec_00(nd_profile, id_ct:nd_layer)
!           Secant of zenith angle
!
!
!     Coefficients in the two-stream equations:
      REAL  (RealK), Intent(OUT) :: &
          trans_cloud(nd_profile, nd_layer) &
!           Mean diffuse transmission coefficient
        , reflect_cloud(nd_profile, nd_layer) &
!           Mean diffuse reflection coefficient
        , trans_0_cloud(nd_profile, nd_layer) &
!           Mean direct transmission coefficient
        , source_coeff_cloud(nd_profile, nd_layer, nd_source_coeff)
!           Mean source coefficients in two-stream equations
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l
!           Loop variable
!
!     Coefficients in the two-stream equations:
      REAL  (RealK) :: &
          trans_temp(nd_profile, 1) &
!           Temporary diffuse transmission coefficient
        , reflect_temp(nd_profile, 1) &
!           Temporary diffuse reflection coefficient
        , trans_0_temp(nd_profile, 1) &
!           Temporary direct transmission coefficient
        , source_coeff_temp(nd_profile, 1, nd_source_coeff)
!           Temporary source coefficients in two-stream equations
!
!     Variables for gathering:
      INTEGER &
          n_list &
!           Number of points in list
        , l_list(nd_profile) &
!           List of collected points
        , ll
!           Loop variable
      REAL  (RealK) :: &
          tau_gathered(nd_profile, 1) &
!           Gathered optical depth
        , omega_gathered(nd_profile, 1) &
!           Gathered alebdo of single scattering
        , asymmetry_gathered(nd_profile, 1) &
!           Gathered asymmetry
        , sec_0_gathered(nd_profile)
!           Gathered asymmetry
!
!     Subroutines called:
!      EXTERNAL &
!           two_coeff
!
!
!
!     Initialize the full arrays.
!
      DO i=i_layer_first, i_layer_last
        DO l=1, n_profile
          trans_cloud(l, i)=0.0e+00_RealK
          reflect_cloud(l, i)=0.0e+00_RealK
        ENDDO
      ENDDO
      DO j=1, n_source_coeff
        DO i=i_layer_first, i_layer_last
          DO l=1, n_profile
            source_coeff_cloud(l, i, j)=0.0e+00_RealK
          ENDDO
        ENDDO
      ENDDO
!
      IF (isolir == IP_solar) THEN
        DO i=i_layer_first, i_layer_last
          DO l=1, n_profile
            trans_0_cloud(l, i)=0.0e+00_RealK
          ENDDO
        ENDDO
      ENDIF
!
!
!     Calculate the transmission and reflection coefficients for
!     each type of cloud and increment the totals, weighting with
!     the cloud fraction.
!
      DO k=1, n_cloud_type
!
        DO i=i_layer_first, i_layer_last
!
!         Determine where cloud of the current type exists
!         in this row and gather the points.
          n_list=0
          DO l=1, n_profile
            IF (frac_cloud(l, i, k) > 0.0e+00_RealK) THEN
              n_list=n_list+1
              l_list(n_list)=l
            ENDIF
          ENDDO
!
!
          IF (n_list > 0) THEN
!
!           Gather the optical properties.
!           Here we must consider one layer at a time. To reduce
!           storage the temporary arrays are only one layer thick,
!           but they will be past to the subroutine where they
!           will be declared as running from the Ith to the Ith layer
!           to make the code more readable at the lower level.
!
            DO l=1, n_list
              tau_gathered(l, 1) &
                =tau_cloud(l_list(l), i, k)
              omega_gathered(l, 1) &
                =omega_cloud(l_list(l), i, k)
              asymmetry_gathered(l, 1) &
                =phase_fnc_cloud(l_list(l), i, 1, k)
            ENDDO
            IF (isolir == IP_solar) THEN
              DO l=1, n_list
                sec_0_gathered(l)=sec_00(l_list(l), 1) !hmjb
              ENDDO
            ENDIF
!
!
            CALL two_coeff(ierr &
              , n_list, i, i &
              , i_2stream, l_ir_source_quad &
              , asymmetry_gathered, omega_gathered &
              , tau_gathered &
              , isolir, sec_0_gathered &
              , trans_temp, reflect_temp, trans_0_temp &
              , source_coeff_temp &
              , nd_profile, i, i, i, i, nd_source_coeff &
              )
            IF (ierr /= i_normal) RETURN
!
            DO l=1, n_list
              ll=l_list(l)
              trans_cloud(ll, i)=trans_cloud(ll, i) &
                +frac_cloud(ll, i, k)*trans_temp(l, 1)
              reflect_cloud(ll, i)=reflect_cloud(ll, i) &
                +frac_cloud(ll, i, k)*reflect_temp(l, 1)
            ENDDO
            DO j=1, n_source_coeff
              DO l=1, n_list
                ll=l_list(l)
                source_coeff_cloud(ll, i, j) &
                  =source_coeff_cloud(ll, i, j) &
                  +frac_cloud(ll, i, k)*source_coeff_temp(l, 1, j)
              ENDDO
            ENDDO
            IF (isolir == IP_solar) THEN
              DO l=1, n_list
                ll=l_list(l)
                trans_0_cloud(ll, i)=trans_0_cloud(ll, i) &
                   +frac_cloud(ll, i, k)*trans_0_temp(l, 1)
              ENDDO
            ENDIF
          ENDIF
!
        ENDDO
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE TWO_COEFF_CLOUD
!+ Subroutine to calculate coefficients in the two-stream equations.
!
! Method:
!        The basic two-stream coefficients in the differential equations
!        are calculated. These are then used to determine the
!        transmission and reflection coefficients. Coefficients for
!        determining the solar or infra-red source terms are calculated.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE two_coeff(ierr &
         , n_profile, i_layer_first, i_layer_last &
         , i_2stream, l_ir_source_quad &
         , asymmetry, omega, tau &
         , isolir, sec_00 & !hmjb
         , trans, reflect, trans_0 &
         , source_coeff &
         , nd_profile &
         , id_op_lt, id_op_lb, id_trs_lt, id_trs_lb &
         , nd_source_coeff &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE error_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , id_op_lt &
!           Topmost declared layer for optical properties
        , id_op_lb &
!           Bottom declared layer for optical properties
        , id_trs_lt &
!           Topmost declared layer for transmission coefficients
        , id_trs_lb &
!           Bottom declared layer for transmission coefficients
        , nd_source_coeff
!           Size allocated for source coefficients
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to consider
        , i_layer_last &
!           Last layer to consider
        , isolir &
!           Spectral region
        , i_2stream
!           Two stream scheme
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source function
!
!     Optical properties of layer:
      REAL  (RealK), Intent(IN) :: &
          asymmetry(nd_profile, id_op_lt: id_op_lb) &
!           Asymmetry factor
        , omega(nd_profile, id_op_lt: id_op_lb) &
!           Albedo of single scattering
        , tau(nd_profile, id_op_lt: id_op_lb)
!           Optical depth
!
!     Solar beam
      REAL  (RealK), Intent(IN) :: &
          sec_00(nd_profile, id_op_lt: id_op_lb)
!           Secant of zenith angle
!
!
!     Coefficients in the two-stream equations:
      REAL  (RealK), Intent(OUT) :: &
          trans(nd_profile, id_trs_lt: id_trs_lb) &
!           Diffuse transmission coefficient
        , reflect(nd_profile, id_trs_lt: id_trs_lb) &
!           Diffuse reflection coefficient
        , trans_0(nd_profile, id_trs_lt: id_trs_lb) &
!           Direct transmission coefficient
        , source_coeff(nd_profile, id_trs_lt: id_trs_lb &
            , nd_source_coeff)
!           Source coefficients in two-stream equations
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l
!           Loop variable
!
!     Coefficients in the two-stream equations:
      REAL  (RealK) :: &
          lambda(nd_profile, id_op_lt: id_op_lb) &
!           Coefficients in two-stream equations
        , sum(nd_profile, id_op_lt: id_op_lb) &
!           Sum of alpha_1 and alpha_2
        , diff(nd_profile, id_op_lt: id_op_lb) &
!           Difference of alpha_1 and alpha_2
        , gamma_up(nd_profile, id_op_lt: id_op_lb) &
!           Basic solar coefficient for upward radiation
        , gamma_down(nd_profile, id_op_lt: id_op_lb)
!           Basic solar coefficient for downward radiation
!
!
!     Subroutines called:
!      EXTERNAL &
!          two_coeff_basic, solar_coefficient_basic &
!        , trans_source_coeff
!
!
!
!     Calculate the basic two-stream coefficients. (The single
!     scattering albedo has already been perturbed away from 1 in
!     SINGLE_SCATTERING.)
      CALL two_coeff_basic(ierr &
        , n_profile, i_layer_first, i_layer_last &
        , i_2stream &
        , asymmetry, omega &
        , sum, diff &
        , nd_profile, id_op_lt, id_op_lb &
        )
      IF (ierr /= i_normal) THEN
        RETURN
      ENDIF
!
!     LAMBDA is now calculated.
!      DO i=i_layer_first, i_layer_last
!        DO l=1, n_profile
!CDIR COLLAPSE
      DO i=id_op_lt, id_op_lb
        DO l=1, nd_profile
          lambda(l, i)=sqrt(sum(l, i)*diff(l, i))
        ENDDO
      ENDDO
!
!
!     Calculate the basic coefficients for the solar source terms.
      IF (isolir == IP_solar) THEN
!       LAMBDA may be perturbed by this routine to avoid
!       ill-conditioning for the singular zenith angle.
        CALL solar_coefficient_basic(ierr &
          , n_profile, i_layer_first, i_layer_last &
          , omega, asymmetry, sec_00 & !hmjb
          , i_2stream &
          , sum, diff, lambda &
          , gamma_up, gamma_down &
          , nd_profile, id_op_lt, id_op_lb &
          )
        IF (ierr /= i_normal) RETURN
      ENDIF
!
!
!     Determine the transmission and reflection coefficients.
      CALL trans_source_coeff(n_profile, i_layer_first, i_layer_last &
        , isolir, l_ir_source_quad &
        , tau, sum, diff, lambda, sec_00 & !hmjb
        , gamma_up, gamma_down &
        , trans, reflect, trans_0, source_coeff &
        , nd_profile &
        , id_op_lt, id_op_lb, id_trs_lt, id_trs_lb &
        , nd_source_coeff &
        )
!
!
!
      RETURN
      END SUBROUTINE TWO_COEFF
!+ Subroutine to calculate coefficients in the two-stream equations.
!
! Method:
!   The basic two-stream coefficients in the differential equations
!   are calculated on the assumption that scattering can be ignored:
!   this routine is therefore only suitable for use in the IR region.
!   These coefficients are then used to determine the transmission
!   and reflection coefficients. Coefficients for determining the
!   solar or infra-red source terms are also calculated.
!
! Current owner of code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First Version under RCS
!                                               (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE two_coeff_fast_lw(n_profile &
        , i_layer_first, i_layer_last &
        , l_ir_source_quad, tau &
        , trans, source_coeff &
        , nd_profile, nd_layer, id_lt, id_lb, nd_source_coeff &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE source_coeff_pointer_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , id_lt &
!           Topmost declared layer of optical depths
        , id_lb &
!           Bottom declared layer of optical depths
        , nd_source_coeff
!           Size allocated for source coefficients
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , i_layer_first &
!           First layer to process
        , i_layer_last
!           Last layer to process
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source function
!
!     Optical properties of layer:
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, id_lt: id_lb)
!           Optical depths
!
!
!     Coefficients in the two-stream equations:
      REAL  (RealK), Intent(OUT) :: &
          trans(nd_profile, nd_layer) &
!           Diffuse transmission coefficient
        , source_coeff(nd_profile, nd_layer, nd_source_coeff)
!           Source coefficients in two-stream equations
!
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , l &
!           Loop variable
        , n_in
!           Number of elements for vector exponential
!
!     Variables related to the treatment of ill-conditioning
      REAL  (RealK) :: &
          eps_r &
!           The smallest real number such that 1.0-EPS_R is not 1
!           to the computer''s precision
        , sq_eps_r
!           The square root of the above
!
!
!
!     Set the tolerances used in avoiding ill-conditioning, testing
!     on any variable.
      eps_r=epsilon(tau(1, id_lt))
      sq_eps_r=sqrt(eps_r)
!
      DO i=i_layer_first, i_layer_last
        DO l=1, n_profile
          trans(l, i)=-1.66e+00_RealK*tau(l, i)
        ENDDO
        DO l=n_profile+1, nd_profile
          trans(l, i)=0.0e+00_RealK
        ENDDO
      ENDDO
      n_in=nd_profile*(i_layer_last-i_layer_first+1)
      CALL exp_v(n_in &
        , trans(1, i_layer_first), trans(1, i_layer_first))
!
      DO i=i_layer_first, i_layer_last
        DO l=1, n_profile
          source_coeff(l, i, IP_scf_ir_1d) &
            =(1.0e+00_RealK-trans(l, i)+sq_eps_r) &
            /(1.66e+00_RealK*tau(l, i)+sq_eps_r)
        ENDDO
      ENDDO
!
      IF (l_ir_source_quad) THEN
        DO i=i_layer_first, i_layer_last
          DO l=1, n_profile
            source_coeff(l, i, IP_scf_ir_2d) &
              =-(1.0e+00_RealK+trans(l, i) &
              -2.0e+00_RealK*source_coeff(l, i, IP_scf_ir_1d)) &
              /(1.66e+00_RealK*tau(l, i)+sq_eps_r)
          ENDDO
        ENDDO
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE TWO_COEFF_FAST_LW
!+ Subroutine to calculate two-stream coefficients in the regions.
!
! Method:
!        The coeffients for each region are determined and
!        averaged.
!
! Current owner of code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First version under RCS
!                                                (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
!DD+ -------------------------------------------------------------------
! Compiler directives for specific computer systems:
!
! Indirect addressing will inhibit vectorization, but here it is safe
! because all points are independent.
!
! Fujistu VPP700:
!OCL NOVREC
!
! Cray vector machines:
!cfpp$ nodepchk r
!
!DD- -------------------------------------------------------------------
   
      SUBROUTINE two_coeff_region(ierr &
         , n_profile, n_layer, n_cloud_top &
         , i_2stream, l_ir_source_quad, n_source_coeff &
         , n_cloud_type, frac_cloud &
         , n_region, i_region_cloud, frac_region &
         , phase_fnc_clr, omega_clr, tau_clr &
         , phase_fnc, omega, tau &
         , isolir, sec_00 & !hmjb
         , trans, reflect, trans_0 &
         , source_coeff &
         , nd_profile, nd_layer, nd_layer_clr, id_ct &
         , nd_max_order, nd_source_coeff &
         , nd_cloud_type, nd_region &
         )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE error_pcf
      USE cloud_region_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_layer_clr &
!           Size allocated for completely clear atmospheric layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_max_order &
!           Size allocated for orders of spherical harmonics
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_cloud_type &
!           Maximum number of types of cloud
        , nd_region
!           Maximum number of cloudy regions
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Topmost cloudy layer
        , isolir &
!           Spectral region
        , n_cloud_type &
!           Number of types of clouds
        , i_2stream &
!           Two stream scheme
        , n_source_coeff
!           Number of source coefficients
!
      INTEGER, Intent(IN) :: &
          n_region &
!           Number of cloudy regions
        , i_region_cloud(nd_cloud_type)
!           Regions in which types of clouds fall
!
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source in the infra-red
!
!     Optical properties of layer:
      REAL  (RealK), Intent(IN) :: &
          frac_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type) &
!           Fractions of different types of clouds
        , frac_region(nd_profile, id_ct: nd_layer, nd_region) &
!           Fractions of total cloud occupied by each region
        , phase_fnc_clr(nd_profile, nd_layer_clr, nd_max_order) &
!           Phase function in clear-sky
        , omega_clr(nd_profile, nd_layer_clr) &
!           Clear-sky albedo of single scattering
        , tau_clr(nd_profile, nd_layer_clr) &
!           Clear-sky optical depth
        , tau(nd_profile, id_ct: nd_layer, 0: nd_cloud_type) &
!           Optical depth
        , omega(nd_profile, id_ct: nd_layer, 0: nd_cloud_type) &
!           Albedo of single scattering
        , phase_fnc(nd_profile, id_ct: nd_layer &
            , nd_max_order, 0: nd_cloud_type)
!           Phase function
!*n-
!**o+
!*     &  , phase_fnc_free(nd_profile, nd_layer, nd_max_order)
!*!           phase function in clear-sky
!*     &  , omega_free(nd_profile, nd_layer)
!*!           clear-sky albedo of single scattering
!*     &  , tau_free(nd_profile, nd_layer)
!*!           clear-sky optical depth
!*     &  , phase_fnc_cloud(nd_profile, id_ct: nd_layer
!*     &      , nd_max_order, nd_cloud_type)
!*!           cloudy phase function
!*     &  , omega_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!*!           albedo of single scattering
!*     &  , tau_cloud(nd_profile, id_ct: nd_layer, nd_cloud_type)
!*!           optical depth
!**o-
!
!     Solar beam
      REAL  (RealK), Intent(IN) :: &
          sec_00(nd_profile, nd_layer)
!           Secant of zenith angle
!
!
!     Coefficients in the two-stream equations:
      REAL  (RealK), Intent(OUT) :: &
          trans(nd_profile, nd_layer, nd_region) &
!           Diffuse transmission coefficient
        , reflect(nd_profile, nd_layer, nd_region) &
!           Diffuse reflection coefficient
        , trans_0(nd_profile, nd_layer, nd_region) &
!           Direct transmission coefficient
        , source_coeff(nd_profile, nd_layer &
          , nd_source_coeff, nd_region)
!           Source coefficients in two-stream equations
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l &
!           Loop variable
        , i_region
!           Loop variable over regions
!
!     Coefficients in the two-stream equations:
      REAL  (RealK) :: &
          trans_temp(nd_profile, nd_layer) &
!           Temporary diffuse transmission coefficient
        , reflect_temp(nd_profile, nd_layer) &
!           Temporary diffuse reflection coefficient
        , trans_0_temp(nd_profile, nd_layer) &
!           Temporary direct transmission coefficient
        , source_coeff_temp(nd_profile, nd_layer, nd_source_coeff)
!           Temporary source coefficients in two-stream equations
!
!     Variables for gathering:
      INTEGER &
          n_list &
!           Number of points in list
        , l_list(nd_profile) &
!           List of collected points
        , ll
!           Loop variable
!
!     Subroutines called:
!      EXTERNAL &
!           two_coeff
!
!
!
!     Determine the optical properties of the clear-sky regions of
!     the layers.
!
!hmjb WE JUST NEED ONE CALL
      CALL two_coeff(ierr &
        , n_profile, 1, n_layer &
        , i_2stream, l_ir_source_quad &
        , phase_fnc(1, id_ct, 1, 0) &
        , omega(1, id_ct, 0), tau(1, id_ct, 0) &
        , isolir, sec_00 &
        , trans(1, 1, IP_region_clear) &
        , reflect(1, 1, IP_region_clear) &
        , trans_0(1, 1, IP_region_clear) &
        , source_coeff(1, 1, 1, IP_region_clear) &
        , nd_profile, id_ct, nd_layer, 1, nd_layer &
        , nd_source_coeff &
        )
      IF (ierr /= i_normal) RETURN
!
!
!     Now deal with clouds.
!
!     Initialize the full arrays for cloudy regions.
!
      DO i_region=1, n_region
        IF (i_region /= IP_region_clear) THEN
          DO i=n_cloud_top, n_layer
            DO l=1, n_profile
              trans(l, i, i_region)=0.0e+00_RealK
              reflect(l, i, i_region)=0.0e+00_RealK
            ENDDO
          ENDDO
          DO j=1, n_source_coeff
            DO i=1, nd_layer
              DO l=1, nd_profile
                source_coeff(l, i, j, i_region)=0.0e+00_RealK
              ENDDO
            ENDDO
          ENDDO
!
          IF (isolir == IP_solar) THEN
            DO i=1, nd_layer
              DO l=1, nd_profile
                trans_0(l, i, i_region)=0.0e+00_RealK
              ENDDO
            ENDDO
          ENDIF
!
        ENDIF
!
      ENDDO
!
!
!
!     Consider each type of cloud in turn, checking which region it
!     contrubutes to and form weighted sums of cloud properties.
!
      DO k=1, n_cloud_type
!
!
!       Set the region in which clouds of this type are included.
        i_region=i_region_cloud(k)

        CALL two_coeff(ierr &
          , nd_profile, 1, nd_layer &
          , i_2stream, l_ir_source_quad &
          , phase_fnc(1, 1, 1, k), omega(1, 1, k) &
          , tau(1, 1, k) &
          , isolir, sec_00 &
          , trans_temp, reflect_temp, trans_0_temp &
          , source_coeff_temp &
          , nd_profile, 1, nd_layer, 1, nd_layer, nd_source_coeff &
          )
        IF (ierr /= i_normal) RETURN

!
!CDIR COLLAPSE
        DO i=1, nd_layer
          DO l=1, nd_profile
            trans(l, i, i_region)=trans(l, i, i_region) &
              +frac_cloud(l, i, k)*trans_temp(l, i)
            reflect(l, i, i_region)=reflect(l, i, i_region) &
              +frac_cloud(l, i, k)*reflect_temp(l, i)
          ENDDO
        ENDDO
!CDIR COLLAPSE
        DO j=1, n_source_coeff
          DO i=1, nd_layer
            DO l=1, nd_profile
              source_coeff(l, i, j, i_region) &
                =source_coeff(l, i, j, i_region) &
                +frac_cloud(l, i, k) &
                *source_coeff_temp(l, i, j)
            ENDDO
          ENDDO
        ENDDO
        IF (isolir == IP_solar) THEN
!CDIR COLLAPSE
          DO i=1, nd_layer
            DO l=1, nd_profile
              trans_0(l, i, i_region)=trans_0(l, i, i_region) &
                +frac_cloud(l, i, k)*trans_0_temp(l, i)
            ENDDO
          ENDDO
        ENDIF
      ENDDO
!
!
!     Finally, scale the weighted sums by the cloud fractions.
      DO i_region=1, n_region
        IF (i_region /= IP_region_clear) THEN

!CDIR COLLAPSE
          DO i=1, nd_layer
            DO l=1, nd_profile
              IF (frac_region(l, i, i_region) > 0.0e+00_RealK) THEN
                trans(l, i, i_region)=trans(l, i, i_region) &
                  /frac_region(l, i, i_region)
                reflect(l, i, i_region)=reflect(l, i, i_region) &
                  /frac_region(l, i, i_region)
              ENDIF
            ENDDO
          ENDDO

!hmjb: PROBLEM WITH VECTORIZATION ON SX6. INVERTING THE i,j LOOPS GIVES
! DIFFERENTE RESULTS, UNLESS ONE USES THE NOVECTOR OPTION. BECAUSE IT IS
! A PROBLEM OF SX6 ARCHITECTURE AND NOT OF THE CODE, I DID INVERT THE LOOP
! BECAUSE IT IS FASTER THIS WAY.
!      THE TIME TO RUN THE SUBROUTINE WAS REDUCED BY A FACTOR OF 3 (THREE).
!      ORIGINAL CODE TOOK 4% OF ALL RADIATION TIME.
!
!CDIR COLLAPSE
          DO j=1, n_source_coeff
            DO i=1, nd_layer
              DO l=1, nd_profile
                IF (frac_region(l, i, i_region) > 0.0e+00_RealK) THEN
                    source_coeff(l, i, j, i_region) &
                      =source_coeff(l, i, j, i_region) &
                      /frac_region(l, i, i_region)
                ENDIF
              ENDDO
            ENDDO
          ENDDO

          IF (isolir == IP_solar) THEN
!CDIR COLLAPSE
            DO i=1, nd_layer
              DO l=1, nd_profile
                IF (frac_region(l, i, i_region) > 0.0e+00_RealK) THEN
                    trans_0(l, i, i_region)=trans_0(l, i, i_region) &
                      /frac_region(l, i, i_region)
                ENDIF
              ENDDO
            ENDDO
          ENDIF
        ENDIF
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE TWO_COEFF_REGION
!+ Subroutine to calculate two-stream coefficients in cloudy regions.
!
! Method:
!        The coefficients for each region are determined and
!       averaged.
!
! Current owner of code: J. M. Edwards
!
! History:
!       Version         Date                    Comment
!       1.0             12-04-95                First version under RCS
!                                               (J. M. Edwards)
!
! Description of code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
!DD+ -------------------------------------------------------------------
! Compiler directives for specific computer systems:
!
! Indirect addressing will inhibit vectorization, but here it is safe
! because all points are independent.
!
! Fujistu VPP700:
!OCL NOVREC
!
! Cray vector machines:
!cfpp$ nodepchk r
!
!DD- -------------------------------------------------------------------
   
      SUBROUTINE two_coeff_region_fast_lw(ierr &
        , n_profile, n_layer, n_cloud_top &
        , l_ir_source_quad, n_source_coeff &
        , n_cloud_type, frac_cloud &
        , n_region, i_region_cloud, frac_region &
        , tau_clr, tau &
        , isolir &
        , trans, reflect, source_coeff &
        , nd_profile, nd_layer, nd_layer_clr, id_ct, nd_source_coeff &
        , nd_cloud_type, nd_region &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE spectral_region_pcf
      USE error_pcf
      USE cloud_region_pcf
      USE def_std_io_icf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Maximum number of profiles
        , nd_layer &
!           Maximum number of layers
        , nd_layer_clr &
!           Maximum number of completely clear layers
        , id_ct &
!           Topmost declared cloudy layer
        , nd_source_coeff &
!           Size allocated for source coefficients
        , nd_cloud_type &
!           Maximum number of types of cloud
        , nd_region
!           Maximum number of cloudy regions
!
!
!
!
!     Dummy arguments.
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , n_cloud_top &
!           Topmost cloudy layer
        , isolir &
!           Spectral region
        , n_cloud_type &
!           Number of types of clouds
        , n_source_coeff
!           Number of source coefficients
!
      INTEGER, Intent(IN) :: &
          n_region &
!           Number of cloudy regions
        , i_region_cloud(nd_cloud_type)
!           Regions in which types of clouds fall
!
      LOGICAL, Intent(IN) :: &
          l_ir_source_quad
!           Use a quadratic source in the infra-red
!
!     optical properties of layer:
      REAL  (RealK), Intent(IN) :: &
          frac_cloud(nd_profile, nd_layer, nd_cloud_type) &
!           Fractions of different types of clouds
        , frac_region(nd_profile, nd_layer, nd_region) &
!           Fractions of total cloud occupied by each region
        , tau_clr(nd_profile, nd_layer_clr) &
!           Clear-sky optical depth
        , tau(nd_profile, id_ct: nd_layer, 0: nd_cloud_type)
!           Optical depth
!
!     Coefficients in the two-stream equations:
      REAL  (RealK), Intent(OUT) :: &
          trans(nd_profile, nd_layer, nd_region) &
!           Diffuse transmission coefficient
        , reflect(nd_profile, nd_layer, nd_region) &
!           Diffuse reflection coefficient
        , source_coeff(nd_profile, nd_layer &
          , nd_source_coeff, nd_region)
!           Source coefficients in two-stream equations
!
!     Local variables.
      INTEGER &
          i &
!           Loop variable
        , j &
!           Loop variable
        , k &
!           Loop variable
        , l &
!           Loop variable
        , i_region
!           Loop variable over regions
!
!     Coefficients in the two-stream equations:
      REAL  (RealK) :: &
          trans_temp(nd_profile, nd_layer) &
!           Temporary diffuse transmission coefficient
        , source_coeff_temp(nd_profile, nd_layer, nd_source_coeff)
!           Temporary source coefficients in two-stream equations
!
!     Variables for gathering:
      INTEGER &
          n_list &
!           Number of points in list
        , l_list(nd_profile) &
!           List of collected points
        , ll
      REAL  (RealK) :: &
          tau_gathered(nd_profile, nd_layer) &
!           Gathered optical depth
        , tmp_inv(nd_profile)
!           Temporary work array
!
!     Subroutines called:
!      EXTERNAL &
!          two_coeff_fast_lw
!
!
!
!     This routine should not be used outside the IR.
      IF (isolir /= IP_infra_red) THEN
        WRITE(iu_err, '(/a)') &
          '*** Error: Erroneous USE of non-scattering code.'
        ierr=i_err_fatal
        RETURN
      ENDIF
!
!     Determine the optical properties of the clear-sky regions of
!     the layers.
!
      CALL two_coeff_fast_lw(n_profile, 1, n_cloud_top-1 &
        , l_ir_source_quad, tau_clr &
        , trans(1, 1, IP_region_clear) &
        , source_coeff(1, 1, 1, IP_region_clear) &
        , nd_profile, nd_layer, 1, nd_layer_clr, nd_source_coeff &
        )
      CALL two_coeff_fast_lw(n_profile, n_cloud_top, n_layer &
        , l_ir_source_quad, tau_clr &
        , trans(1, 1, IP_region_clear) &
        , source_coeff(1, 1, 1, IP_region_clear) &
        , nd_profile, nd_layer, id_ct, nd_layer, nd_source_coeff &
        )
      IF (ierr /= i_normal) RETURN
      DO i=1, n_layer
        DO l=1, n_profile
          reflect(l, i, IP_region_clear)=0.0e+00_RealK
        ENDDO
      ENDDO
!
!
!     Now deal with clouds.
!
!     Initialize the full arrays for cloudy regions.
!
      DO i_region=1, n_region
        IF (i_region /= IP_region_clear) THEN
          DO i=n_cloud_top, n_layer
            DO l=1, n_profile
              trans(l, i, i_region)=0.0e+00_RealK
              reflect(l, i, i_region)=0.0e+00_RealK
            ENDDO
          ENDDO
          DO j=1, n_source_coeff
            DO i=n_cloud_top, n_layer
              DO l=1, n_profile
                source_coeff(l, i, j, i_region)=0.0e+00_RealK
              ENDDO
            ENDDO
          ENDDO
!
        ENDIF
!
      ENDDO
!
!
!
!     Consider each type of cloud in turn, checking which region it
!     contrubutes to and form weighted sums of cloud properties.
!
      DO k=1, n_cloud_type
!
!
!       Set the region in which clouds of this type are included.
        i_region=i_region_cloud(k)
!
        DO i=n_cloud_top, n_layer
!
!         Form a list of points where cloud of this type exists
!         on this row for gathering.
          n_list=0
          DO l=1, n_profile
            IF (frac_cloud(l, i, k) > 0.0e+00_RealK) THEN
              n_list=n_list+1
              l_list(n_list)=l
            ENDIF
          ENDDO
!
!
          IF (n_list > 0) THEN
!
!           Gather the optical properties. Though we consider only
!           one layer at a time the lower routines will operate on
!           arrays with vertical structure, so the gathered arrays
!           are two-dimensional.
!
            DO l=1, n_list
              tau_gathered(l, i)=tau(l_list(l), i, k)
            ENDDO
!
            CALL two_coeff_fast_lw(n_list, i, i &
              , l_ir_source_quad, tau_gathered &
              , trans_temp &
              , source_coeff_temp &
              , nd_profile, nd_layer, id_ct, nd_layer, nd_source_coeff &
              )
            IF (ierr /= i_normal) RETURN
!
            DO ll=1, n_list
              l=l_list(ll)
              trans(l, i, i_region)=trans(l, i, i_region) &
                +frac_cloud(l, i, k)*trans_temp(ll, i)
            ENDDO
            DO j=1, n_source_coeff
              DO ll=1, n_list
                l=l_list(ll)
                source_coeff(l, i, j, i_region) &
                  =source_coeff(l, i, j, i_region) &
                  +frac_cloud(l, i, k) &
                  *source_coeff_temp(ll, i, j)
              ENDDO
            ENDDO
!
          ENDIF
!
        ENDDO
      ENDDO
!
!
!     Finally, scale the weighted sums by the cloud fractions.
      DO i_region=1, n_region
        IF (i_region /= IP_region_clear) THEN
          DO i=n_cloud_top, n_layer
!
!           Gather points within this region.
            n_list=0
            DO l=1,n_profile
              IF (frac_region(l, i, i_region) > 0.0e+00_RealK) THEN
                n_list=n_list+1
                l_list(n_list)=l
              ENDIF
            ENDDO
            DO ll=1, n_list
              l=l_list(ll)
              tmp_inv(ll)=1.0e+00_RealK/frac_region(l, i, i_region)
              trans(l, i, i_region)=trans(l, i, i_region) &
                *tmp_inv(ll)
            ENDDO
            DO j=1, n_source_coeff
              DO ll=1, n_list
                l=l_list(ll)
                source_coeff(l, i, j, i_region) &
                  =source_coeff(l, i, j, i_region) &
                  *tmp_inv(ll)
              ENDDO
            ENDDO
          ENDDO
        ENDIF
      ENDDO
!
!
!
      RETURN
      END SUBROUTINE TWO_COEFF_REGION_FAST_LW
!+ Subroutine to solve the two-stream equations in a column.
!
! Method:
!        The coefficients of the two-stream equations are calculated.
!        From these we obtain the transmission and reflection
!        coefficients and the source terms. Depending on the solver
!        selected, an appropriate set of matrix equations is formulated
!        and solved to give the fluxes.
!
! Current Owner of Code: J. M. Edwards
!
! History:
!        Version                Date                        Comment
!        1.0                12-04-95                First Version under RCS
!                                                (J. M. Edwards)
!
! Description of Code:
!   FORTRAN 77  with extensions listed in documentation.
!
!- ---------------------------------------------------------------------
   
      SUBROUTINE two_stream(ierr &
!                        Atmospheric Properties
        , n_profile, n_layer &
!                        Two-stream Scheme
        , i_2stream &
!                        Options for Solver
        , i_solver &
!                        Options for Equivalent Extinction
        , l_scale_solar, adjust_solar_ke &
!                        Spectral Region
        , isolir &
!                        Infra-red Properties
        , diff_planck &
        , l_ir_source_quad, diff_planck_2 &
!                        Conditions at TOA
        , flux_inc_down, flux_inc_direct, sec_00 & !hmjb
!                        Surface Conditions
        , diffuse_albedo, direct_albedo, d_planck_flux_surface &
!                        Single Scattering Properties
        , tau, omega, asymmetry &
!                        Fluxes Calculated
        , flux_direct, flux_total &
!                        Dimensions
        , nd_profile, nd_layer, nd_source_coeff &
        )
!
!
!
!     Modules to set types of variables:
      USE realtype_rd
      USE def_std_io_icf
      USE error_pcf
      USE solver_pcf
      USE spectral_region_pcf
!
!
      IMPLICIT NONE
!
!
!     Sizes of dummy arrays.
      INTEGER, Intent(IN) :: &
          nd_profile &
!           Size allocated for profiles
        , nd_layer &
!           Size allocated for layers
        , nd_source_coeff
!           Size allocated for source coefficients
!
!
!     Dummy variables.
      INTEGER, Intent(IN) :: &
          n_profile &
!           Number of profiles
        , n_layer &
!           Number of layers
        , isolir &
!           Spectral region
        , i_solver &
!           Solver employed
        , i_2stream
!           Two-stream scheme
      INTEGER, Intent(INOUT) :: &
          ierr
!           Error flag
      LOGICAL, Intent(IN) :: &
          l_scale_solar &
!           Scaling applied to solar flux
        , l_ir_source_quad
!           Use quadratic source term
      REAL  (RealK), Intent(IN) :: &
          tau(nd_profile, nd_layer) &
!           Optical depth
        , omega(nd_profile, nd_layer) &
!           Albedo of single scattering
        , asymmetry(nd_profile, nd_layer) &
!           Asymmetry
        , sec_00(nd_profile, nd_layer) &
!           Secants of solar zenith angles
        , diffuse_albedo(nd_profile) &
!           Diffuse albedo
        , direct_albedo(nd_profile) &
!           Direct albedo
        , flux_inc_down(nd_profile) &
!           Incident total flux
        , flux_inc_direct(nd_profile) &
!           Incident direct flux
        , diff_planck(nd_profile, nd_layer) &
!           Difference in Planckian fluxes across layers
        , d_planck_flux_surface(nd_profile) &
!           Ground source function
        , adjust_solar_ke(nd_profile, nd_layer) &
!           Adjustment of solar beam with equivalent extinction
        , diff_planck_2(nd_profile, nd_layer)
!           2x2nd differences of Planckian
      REAL  (RealK), Intent(OUT) :: &
          flux_direct(nd_profile, 0: nd_layer) &
!           Direct flux
        , flux_total(nd_profile, 2*nd_layer+2)
!           Total fluxes
!
!
!     Local variables.
      INTEGER &
          n_equation
!           Number of equations
      REAL  (RealK) :: &
          trans(nd_profile, nd_layer) &
!           Transmission of layer
        , reflect(nd_profile, nd_layer) &
!           Reflectance of layer
        , trans_0(nd_profile, nd_layer) &
!           Direct transmittance
        , source_coeff(nd_profile, nd_layer, nd_source_coeff) &
!           Source coefficients
        , s_down(nd_profile, nd_layer) &
!           Downward source
        , s_up(nd_profile, nd_layer)
!           Upward source
      REAL  (RealK) :: &
          a5(nd_profile, 5, 2*nd_layer+2) &
!           Pentadigonal matrix
        , b(nd_profile, 2*nd_layer+2) &
!           RHS of matrix equation
        , work_1(nd_profile, 2*nd_layer+2)
!           Working array for solver
!
!     Subroutines called:
!      EXTERNAL &
!          two_coeff, solar_source, ir_source &
!        , set_matrix_pentadiagonal &
!        , band_solver, solver_homogen_direct
!
!
!
!     Calculate the two-stream coefficients.
      CALL two_coeff(ierr &
        , n_profile, 1, n_layer &
        , i_2stream, l_ir_source_quad &
        , asymmetry, omega, tau &
        , isolir, sec_00 & !hmjb
        , trans, reflect, trans_0 &
        , source_coeff &
        , nd_profile, 1, nd_layer, 1, nd_layer, nd_source_coeff &
        )
      IF (ierr /= i_normal) RETURN
!
!     Calculate the appropriate source terms.
      IF (isolir == IP_solar) THEN
        CALL solar_source(n_profile, n_layer &
          , flux_inc_direct &
          , trans_0, source_coeff &
          , l_scale_solar, adjust_solar_ke &
          , flux_direct &
          , s_down, s_up &
          , nd_profile, nd_layer, nd_source_coeff &
          )
      ELSE IF (isolir == IP_infra_red) THEN
        CALL ir_source(n_profile, 1, n_layer &
          , source_coeff, diff_planck &
          , l_ir_source_quad, diff_planck_2 &
          , s_down, s_up &
          , nd_profile, nd_layer, nd_source_coeff &
          )
      ENDIF
!
!     Select an appropriate solver for the equations of transfer.
!
      IF (i_solver == IP_solver_pentadiagonal) THEN
        CALL set_matrix_pentadiagonal(n_profile, n_layer &
          , trans, reflect &
          , s_down, s_up &
          , diffuse_albedo, direct_albedo &
          , flux_direct(1, n_layer), flux_inc_down &
          , d_planck_flux_surface &
          , a5, b &
          , nd_profile, nd_layer &
          )
        n_equation=2*n_layer+2
!
        CALL band_solver(n_profile, n_equation &
          , 2, 2 &
          , a5, b &
          , flux_total &
          , work_1 &
          , nd_profile, 5, 2*nd_layer+2 &
          )
!
      ELSE IF (i_solver == IP_solver_homogen_direct) THEN
!
        CALL solver_homogen_direct(n_profile, n_layer &
          , trans, reflect &
          , s_down, s_up &
          , isolir, diffuse_albedo, direct_albedo &
          , flux_direct(1, n_layer), flux_inc_down &
          , d_planck_flux_surface &
          , flux_total &
          , nd_profile, nd_layer &
          )
!
      ELSE
!
        WRITE(iu_err, '(/a)') &
          '***Error: The solver and the cloud scheme are incompatiable.'
        ierr=i_err_fatal
        RETURN
!
      ENDIF
!
!
!
      RETURN
      END SUBROUTINE TWO_STREAM
END MODULE ESRAD
!-----------------------------------------------------------------
!
! Author: Henrique M. J. Barbosa (henrique.barbosa@cptec.inpe.br)
!
! First Version: 2006
!
! Last Modification: 21 April 2009
!
! Description:
!
!    This module contains the necessary subroutines to do the 
! interface between CPTEC AGCM and ESRAD. The first version had
! a complicated procedure of reading the spectral files, 
! initializing and configuring the calls to radiance calc().
!    The new version from April 2009 now uses an ESRAD routine
! to read the spectral file and store the data in an ESRAD type
! variable which contains almost all information. The other options
! are initialized directly inside swintf() and lwintf() via
! parameter declarations.
!
!-----------------------------------------------------------------
MODULE Rad_UKMO
    USE angular_integration_pcf
    USE cloud_component_pcf
    USE cloud_representation_pcf
    USE cloud_scheme_pcf
    USE cloud_type_pcf
    USE def_spectrum
    USE dimensions_field_ucf
    USE dimensions_fixed_pcf
    USE dimensions_spec_ucf
    USE error_pcf
    USE gas_overlap_pcf
    USE physical_constants_1_ccf
    USE scatter_method_pcf
    USE solver_pcf
    USE spectral_region_pcf
    USE surface_spec_pcf
    USE two_stream_scheme_pcf


    USE Constants, only: i8, r8

    PRIVATE

    PUBLIC :: ukmo_swintf
    PUBLIC :: ukmo_lwintf
    PUBLIC :: InitRadUKMO
    PUBLIC :: DestroyRadUKMO

    ! Data read from spectral files
    TYPE (StrSpecData) :: swdat
    TYPE (StrSpecData) :: lwdat

    ! Climatological aerosols
    ! This is not exactly the mixing ratios of climatological aerosols
    !  - in the stratosphere (range 1:nls), we have to divide by p_star (surface pressure)
    !  - in the troposphere and boundary layer its ok, since p_star cancel out
    !     and we are left with a p_0 in the denominator (which is included already)
    REAL(KIND=r8), ALLOCATABLE, DIMENSION(:,:) :: aerosol_clim_land 
    REAL(KIND=r8), ALLOCATABLE, DIMENSION(:,:) :: aerosol_clim_ocean

    ! Molucular weights in g/mol
    REAL(KIND=r8), PARAMETER :: dryair_mol_mass  = 28.966_r8
    REAL(KIND=r8), PARAMETER :: H2O_mol_mass     = 18.0153_r8
    REAL(KIND=r8), PARAMETER :: O2_mol_mass      = 31.9988_r8
    REAL(KIND=r8), PARAMETER :: O3_mol_mass      = 47.9982_r8
    REAL(KIND=r8), PARAMETER :: CO2_mol_mass     = 44.0095_r8
    REAL(KIND=r8), PARAMETER :: N2O_mol_mass     = 44.0128_r8
    REAL(KIND=r8), PARAMETER :: CH4_mol_mass     = 16.0425_r8           
    REAL(KIND=r8), PARAMETER :: CFC11_mol_mass   =  137.37_r8 ! CCl3F      
    REAL(KIND=r8), PARAMETER :: CFC12_mol_mass   =  120.91_r8 ! CCl2F2     
    REAL(KIND=r8), PARAMETER :: CFC113_mol_mass  =  187.38_r8 ! CCl2F-CClF2
    REAL(KIND=r8), PARAMETER :: HCFC22_mol_mass  =  86.468_r8 ! CHClF2     
    REAL(KIND=r8), PARAMETER :: HFC125_mol_mass  =  120.02_r8 ! CF3CHF2    
    REAL(KIND=r8), PARAMETER :: HFC134a_mol_mass =  102.03_r8 ! CH2FCF3    

CONTAINS

  !---------------------------------------------------------------------------
  !
  ! InitRadUKMO
  ! 
  ! Read data from all spectralfiles and intialize variables
  !
  ! Author: Henrique Barbosa
  !
  !---------------------------------------------------------------------------
  SUBROUTINE InitRadUKMO(kmax, sl, nls)
    USE Options, ONLY: fNameSpecSW, nfspecsw, fNameSpecLW, nfspeclw
    USE Parallelism, only: MsgOne
    USE ESRAD, only: read_spectrum_90

    IMPLICIT NONE

    INTEGER      , INTENT(IN   ) :: kmax, nls
    REAL(KIND=r8), INTENT(in   ) :: sl   (kmax)

    integer :: ierr
    CHARACTER(LEN=*), PARAMETER :: h="**(InitRadUKMO)**"

    ! Configure options for SW calls
    CALL MsgOne(h," Reading UKMO SW Spectral file")
    CALL read_spectrum_90(fNameSpecSW, swdat, ierr)

    ! Configure options for LW calls
    CALL MsgOne(h," Reading UKMO LW Spectral file")
    CALL read_spectrum_90(fNameSpecLW, lwdat, ierr)

    ! Create basic aerosol profiles
    CALL MsgOne(h," Creating Aerosol Climatology")
    CALL InitAerClim(kmax, sl, nls)

  END SUBROUTINE InitRadUKMO

  SUBROUTINE InitAerClim(kmax, sl, nls)
    USE Parallelism, only: MsgOne
    IMPLICIT NONE

    INTEGER      , INTENT(IN   ) :: kmax, nls
    REAL(KIND=r8), INTENT(in   ) :: sl   (kmax)

    ! LOCAL VARIABLES
    INTEGER :: i,k
    REAL(kind=r8) :: FlipSl(kmax) ! sigma coordinate at bottom of layers (TOA at k=1)

    CHARACTER(LEN=*), PARAMETER :: h="**(InitAerClim)**"
    CHARACTER(LEN=128) :: line

    ! first layer above PBL (i=1 at top, i=kmax at ground)
    ! PBL exists between sigma=FlipSl(i_boundl) and sigma=1.0
    ! Points to the lowest layer with bottom above sigma=0.95
    INTEGER :: i_boundl

    !---------------------------------------------------------------------------
    ! CLIMATOLOGICAL AEROSOL DATA
    !---------------------------------------------------------------------------

    ! total column mass (kg m-2) of each aerosol species in
    ! the boundary layer, the free troposphere and the stratosphere
    ! respectively. this model assumes that there are five kinds of aerosols.
    REAL(kind=r8) :: bl_oceanmass(5), bl_landmass(5), freetrop_mass(5), strat_mass(5)

    ! initialization for the climatological aerosol model
    ! this assumes that climatological aerosols (1-5)
    ! are in this order: water, dust, oceanic, soot and sufur
    ! this corresponds to UKMO types 1,2,3,4 and 6
    ! in the spectral file, however, type 5 is not present. Hence
    ! the indexes of the climatological aerosols we have to use
    ! is 1,2,3,4 and 5.
    DATA bl_landmass   /2.77579e-5_r8, 6.70018e-5_r8,         0.0_r8, 9.57169e-7_r8,        0.0_r8/
    DATA bl_oceanmass  /1.07535e-5_r8,        0.0_r8, 2.043167e-4_r8,        0.0_r8,        0.0_r8/
    DATA freetrop_mass /3.46974e-6_r8, 8.37523e-6_r8,         0.0_r8, 1.19646e-7_r8,        0.0_r8/
    DATA strat_mass    /0.0_r8       ,        0.0_r8,         0.0_r8,        0.0_r8, 1.86604e-6_r8/

    !---------------------------------------------------------------------------
    ! SUBROUTINE STARTS HERE
    !---------------------------------------------------------------------------

    ! Allocate memory
    ALLOCATE(aerosol_clim_land(kMax,5))
    ALLOCATE(aerosol_clim_ocean(kMax,5))

    ! Define vertical coordinate
    if (sl(1)>sl(2)) then
       ! ground is at k=1, we have to flip
       FlipSl = sl(kmax:1:-1)
    else
       ! ground is at k=kmax, no need to flip
       FlipSl = sl
    endif

    ! Print climatology
    CALL MsgOne(h,' Number of climatological aerosols: 5')
    CALL MsgOne(h,'                            Total column mass (kg m-2) ')
    CALL MsgOne(h,' Index   Aertype  bl_land      bl_ocean     free_trop    strat ')
    DO i=1,5
       WRITE(line,'(2(i5,3x),1P,4(1x,E12.5))') i,lwdat%Aerosol%type_aerosol(i), &
            bl_landmass(i),bl_oceanmass(i),freetrop_mass(i),strat_mass(i)
       CALL MsgOne(h,trim(line))
    ENDDO

    ! Search for the boundary layer
    ! Cusack et al., QJR Meteorol. Soc., v.124, pp2517-2526
    ! define the BL to go up to 750hPa
    DO k=1,kMax
       if (FlipSl(k+1)>0.75_r8) exit
    ENDDO
    ! notice that i_boundl actually points to the first layer above 750mb
    i_boundl=k
    WRITE(line,'("B.L. ends at the bottom of ",i3,"th layer, at sigma=",F6.4)') &
         i_boundl,FlipSl(i_boundl)
    CALL MsgOne(h,trim(line))

    ! notice that nls points to the last layer in the stratosphere 
    WRITE(line,'("Stratosphere starts at the bottom of ",i3,"th layer, at sigma=",F6.4)') &
         nls,FlipSl(nls)
    CALL MsgOne(h,trim(line))

    ! for each of the 5 aerosol species, the column amount in the
    ! boundary layer, free troposphere and stratosphere are known for
    ! a standard atmosphere over ocean and land. these can be used
    ! to find mixing ratios for the UM by dividing total aerosol by
    ! total air mass (and using pressure weighting in the
    ! troposphere).

    ! firstly, mixing ratios are set for the 5 aerosol species in the
    ! stratosphere.
    DO i=1,5
       aerosol_clim_land(1:nls, i) &
            = strat_mass(i)*grav_acc/(FlipSl(nls)-0.0_r8)

       aerosol_clim_ocean(1:nls, i) &
            = strat_mass(i)*grav_acc/(FlipSl(nls)-0.0_r8)
    END DO

    ! now, the mixing ratios are set for the 5 aerosol species
    ! in the free troposphere. 
    DO i=1,5
       !   kg        m         m2    s2 
       ! -------* ------- * --------------
       !   m2       s2          kg * m        
       aerosol_clim_land(nls+1:i_boundl, i) &
            = freetrop_mass(i)*grav_acc/(FlipSl(i_boundl)-FlipSl(nls))/1.013e5_r8

       aerosol_clim_ocean(nls+1:i_boundl, i) &
            = freetrop_mass(i)*grav_acc/(FlipSl(i_boundl)-FlipSl(nls))/1.013e5_r8
    END DO

    ! now, the boundary layer mixing ratios are set for the
    ! 5 aerosol species. a continental aerosol is used over most land
    ! areas, but not over ice sheets, which are identified by the
    ! criterion used in the boundary layer scheme that the mass of
    ! lying snow exceeds 5000 kgm-2. over ice sheets a maritime
    ! aerosol is used.
    DO i=1,5
       aerosol_clim_land(i_boundl+1:kMax, i) &
            = bl_landmass(i)*grav_acc/( 1.0_r8-FlipSl(i_boundl))/1.013e5_r8

       aerosol_clim_ocean(i_boundl+1:kMax, i) &
            = bl_oceanmass(i)*grav_acc/(1.0_r8-FlipSl(i_boundl))/1.013e5_r8
    ENDDO

    RETURN
  END SUBROUTINE InitAerClim

  SUBROUTINE DestroyRadUKMO

    IMPLICIT NONE

    ! Destroy basic aerosol profiles
    DEALLOCATE(aerosol_clim_land)
    DEALLOCATE(aerosol_clim_ocean)

  END SUBROUTINE DestroyRadUKMO

  ! SWINTF ("ShortWave INTerFace")
  ! to replace SWRAD into the global model
  ! (using nearly the same input and output, with additions, when necessary),
  ! to call RADIANCE_CALC (calculates SW fluxes).
  ! 
  ! RADIANCE_CALC is the main routine of the Edwards & Slingo radiation code.
  !
  ! Authors: Julio Chagas & Henrique Barbosa
  !
  !---------------------------------------------------------------------------
  SUBROUTINE ukmo_swintf(&
       ! Model Info and flags
       ncols         ,kmax          ,                               &
       ! Solar field
       cosz          ,s0            ,                               &
       ! Atmospheric fields
       Pbot          ,Pmid          ,DP            ,Te            , &
       Qe            ,O3            ,co2val        ,Tg            , &
       ! SURFACE:  albedo
       imask         ,                                              &
       AlbVisDiff    ,AlbNirDiff    ,AlbVisBeam    ,AlbNirBeam    , &
       ! SW Radiation fields 
       ToaDown       ,&
       SfcVisBeam    ,SfcVisDiff    ,SfcNirBeam    ,SfcNirDiff    , &
       SfcVisBeamC   ,SfcVisDiffC   ,SfcNirBeamC   ,SfcNirDiffC   , &
       ToaNetC       ,ToaNet        ,SfcNet        ,SfcNetC       , &
       HeatRateC     ,HeatRate      ,                               &
       ! Cloud field
       cld           ,clu           ,fice          ,                &
       rei           ,rel           ,lmixr                            )

      USE ESRAD, only: radiance_calc

      USE Init, only: nls

      IMPLICIT NONE

      !---------------------------------------------------------------------------
      ! INPUT VARIABLES
      !---------------------------------------------------------------------------

      ! Number of atmospheric columns to solve
      INTEGER, INTENT(in) :: ncols
      ! Number of atmospheric levels
      INTEGER, INTENT(in) :: kmax

      ! Solar constant  at proper sun-earth distance (W/m2)
      REAL(KIND=r8), INTENT(in) :: s0                  

      REAL(KIND=r8), DIMENSION(ncols), INTENT(in) :: &
           ! visible diffuse surface albedo
             AlbVisDiff &
           ! near-ir diffuse surface albedo
           , AlbNirDiff &
           ! visible beam surface albedo
           , AlbVisBeam &
           ! near-ir beam surface albedo
           , AlbNirBeam &
           ! cosine of the solar zenith angle
           , cosz &
           ! Ground surface temperature (K)
           , Tg

      REAL(KIND=r8), DIMENSION(ncols,kmax), INTENT(in) :: &
           ! Pressure at bottom of layers (mb)
             Pbot &
           ! Pressure at Middle of Layer(mb)
           , Pmid &
           ! Pressure difference bettween levels (mb)
           , DP &
           ! Temperature at middle of Layer (K)
           , Te &
           ! Specific Humidity at middle of layer (g/g)
           , Qe &
           ! Ozone Mixing ratio at middle of layer (g/g)
           , O3 &
           ! Large scale cloud amount in layers
           , cld &
           ! Cumulus cloud amount in layers
           , clu &
           ! fractional amount of cloud that is ice
           , fice &
           ! Ice particle Effective Radius (microns)
           , rei &
           ! Liquid particle Effective Radius (microns)
           , rel &
           ! ice/water mixing ratio
           , lmixr

      ! co2 concentration in ppmv
      REAL(KIND=r8), INTENT(in) :: co2val

      ! vegetagion mask (0=ocean, -1=sea ice and 13=land ice)
      INTEGER(KIND=i8), INTENT(IN) :: imask (ncols)

      !---------------------------------------------------------------------------
      ! OUTPUT VARIABLES
      !---------------------------------------------------------------------------
                                                               
      REAL(KIND=r8), DIMENSION(ncols), INTENT(inout) :: &
           ! Downward Surface SW flux visible beam (clear)    
             SfcVisBeamC &
           ! Downward Surface SW flux visible diffuse (clear)
           , SfcVisDiffC &
           ! Downward Surface SW flux Near-IR beam (clear)
           , SfcNirBeamC &
           ! Downward Surface SW flux Near-IR diffuse (clear)
           , SfcNirDiffC &
           ! Downward Surface SW flux visible beam (cloudy)
           , SfcVisBeam  &
           ! Downward Surface SW flux visible diffuse (cloudy)
           , SfcVisDiff  &
           ! Downward Surface SW flux Near-IR beam (cloudy)
           , SfcNirBeam  &
           ! Downward Surface SW flux Near-IR diffuse (cloudy)
           , SfcNirDiff  &
           ! Net Solar flux at top of atmosphere (cloudy)
           , ToaNet      &
           ! Net Solar flux at top of atmosphere (clear)
           , ToaNetC     &
           ! Net Solar flux at surface (cloudy)
           , SfcNet      &
           ! Net Solar flux at surface (clear)
           , SfcNetC     &
           ! Solar flux at top of atmosphere                              
           , ToaDown

      REAL(KIND=r8), DIMENSION(ncols,kmax), INTENT(inout) :: &
           ! Heating rate (clear case) (K/s)                          
             HeatRateC &
           ! Heating rate (cloudy case) (K/s)                         
           , HeatRate

      !---------------------------------------------------------------------------
      ! ESRAD CONFIGURATION and VARIABLES
      !---------------------------------------------------------------------------

!     Treatment of errors:
      INTEGER &
          ierr
!           Error flag
!
!     Derived dimensions:
      INTEGER :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_layer_clr &
!           Size allocated for totally clear layers
        , nd_2sg_profile &
!           Number of profiles in arrays of fluxes
        , nd_flux_profile
!           Number of profiles in arrays of output fluxes

      INTEGER, PARAMETER :: &
          nd_radiance_profile = 1 &
!           Number of profiles in arrays of radiances
        , nd_j_profile = 1 &
!           Number of profiles in arrays of mean radiances
        , id_ct = 1 &
!           Topmost declared cloudy layer
        , nd_channel = 2 &
!           Size allocated for profiles of radiances
        , nd_esft_term = 25 &
!           Size allocated for ESFT terms
        , nd_source_coeff = 2 &
!           Size allocated for two-stream source coefficients
        , nd_brdf_basis_fnc = 2 &
!           Size allocated for BRDF basis functions
        , nd_brdf_trunc = 5 &
!           Size allocated for BRDF truncation
        , nd_column = 1 &
!           Size allocated for columns at each grid-point
        , nd_max_order = 1 &
!           Size allocated for polar orders
        , nd_direction = 1 &
!           Size allocated for viewing directions at each point
        , nd_viewing_level = 1 &
!           Size allocated for levels where the radiance may be calculated
        , nd_cloud_type = 4 &
!           Size allocated for types of clouds
        , nd_cloud_component = 4 &
!           Size allocated for components in clouds
        , nd_overlap_coeff = 18 &
!           Size allocated for overlap coefficients
        , nd_sph_coeff = 1 &
!           Size allocated for arrays of spherical coeff used in determining radiances
        , nd_point_tile = 1 &
!           Size allocated for points with surface tiling
        , nd_tile = 1 &
!           Size allocated for the number of tiles
        , nd_region = 3
!           Size allocated for ice crystal types
!
!           Name of spectral file
      INTEGER, PARAMETER :: &
          nmin = 1 &
!           Sorted first band
        , nmax = 6
!           Sorted last band
      REAL  (RealK) :: &
          weight_band(swdat%Dim%nd_band)
!           Weights for each band
!
!
!     Physical processes included
      LOGICAL, PARAMETER :: &
          l_rayleigh = .true. &
!           Flag for Rayleigh scattering
        , l_aerosol = .true. &
!           Flag for the direct effects of aerosols
        , l_gas = .true. &
!           Flag for gaseous absorption
        , l_continuum = .true. &
!           Flag for continuum absorption
        , l_drop = .true. &
!           Flag for water droplets
        , l_ice = .true. &
!           Flag for ice crystals
        , l_cloud = .true. &
!           Flag for cloud processes
        , l_global_cloud_top = .true.
!           Use a global value for the top of clouds
!           (This is for use in a GCM where the code must be
!           bit-reproducible across different configurations of PEs).
      LOGICAL :: &
          l_doppler(swdat%Dim%nd_species)
!           Flag for Doppler broadening
      INTEGER, PARAMETER :: &
          n_global_cloud_top = 1
!           Global cloud top
!
       ! Doppler correction terms
      REAL (RealK) :: &
           doppler_correction(swdat%Dim%nd_species)
!
!     Angular integration
      INTEGER, PARAMETER :: &
          i_angular_integration = IP_two_stream &
!           Type of angular integration
        , i_2stream = IP_pifm80 &
!           Type of two-stream scheme
        , n_order_gauss = 0 &
!           Order of Gaussian integration (IR only)
        , i_truncation = 0 &
!           Type of truncation
        , ls_global_trunc = 0 &
!           Overall order of truncation with spherical harmonics
        , ms_min = 0 &
!           Lowest azimuthal order calculated
        , ms_max = 0 &
!           Highest azimuthal order calculated
        , ls_brdf_trunc = 0 &
!           Order of truncation applied to BRDFs
        , n_order_forward = 2 &
!           Order of term used to `define'' the
!           forward scattering fraction
        , i_sph_mode = 0 &
!           Mode in which the spherical solver is used
        , i_sph_algorithm = 0 &
!           Algorithm used for spherical harmonic calculation
        , n_order_phase_solar = 1
!           Number of terms in the phase function used for
!           singly scattered solar radiation in an iterative
!           solution
      LOGICAL, PARAMETER :: &
          l_rescale = .true. &
!           Flag for rescaling of the phase function
        , l_ir_source_quad = .false. &
!           Flag to use a quadratic source function in the IR
        , l_henyey_greenstein_pf = .true.
!           Flag for Henyey-Greenstein phase functions
      REAL  (RealK), PARAMETER :: &
          accuracy_adaptive = 0.0_r8 &
!           Accuracy used for adaptive truncation
        , euler_factor = 0.0_r8
!           Factor applied to the last term of an alternating series
!
!     Treatment of scattering
      INTEGER :: &
          i_scatter_method(swdat%Dim%nd_band)
!           Method of treating scattering
!
!     Viewing geometry
      INTEGER, PARAMETER :: &
          n_direction = 0 
!           Number of viewing directions
      REAL(RealK), DIMENSION(nd_radiance_profile, nd_direction, 2) :: &
          direction
!           Viewing angles
!
!     Levels of viewing
      INTEGER, PARAMETER :: &
          n_viewing_level = 0
!           Number of levels where radiances are required
      REAL(RealK), DIMENSION(nd_viewing_level) :: &
          viewing_level
!           List of required levels: space is allocated so that
!           either radiances or fluxes may be calculated
!
!     Ouput properties:
      INTEGER :: &
          map_band_channel(swdat%Dim%nd_band)
!           Mapping of spectral bands to channels
!
!     Options for solvers:
      LOGICAL, PARAMETER :: &
          l_clear = .true.
!           Solve for clear-sky fluxes as well as cloudy fluxes
      INTEGER, PARAMETER :: &
!          i_solver = IP_solver_homogen_direct& !(must agree with i_cloud)
          i_solver = IP_solver_triple &
!           Type of main solver
        , i_solver_clear = IP_solver_homogen_direct
!           Type of solver for clear-sky fluxes
!
!     General atmospheric properties
      INTEGER :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:) :: &
          pres &
!           Pressures in layers
        , temp &
!           Temperatures in layers
        , t_level &
!           Temperatures at the boundaries of layers
        , d_mass
!           Masses in layers
!
!     Prescribed optical properties
!
      INTEGER, Parameter :: nd_profile_aerosol_prsc = 1
!       Size allocated for profiles of prescribed
!       cloudy optical properties
      INTEGER, Parameter :: nd_profile_cloud_prsc = 1
!       Size allocated for profiles of prescribed
!       aerosol optical properties
      INTEGER, Parameter :: nd_opt_level_aerosol_prsc = 1
!       Size allocated for levels of prescribed
!       cloudy optical properties
      INTEGER, Parameter :: nd_opt_level_cloud_prsc = 1
!       Size allocated for levels of prescribed
!       aerosol optical properties

!     Droplets:
      INTEGER, Parameter :: &
          n_opt_level_drop_prsc = 1 &
!           Number of levels of prescribed
!           optical properties of droplets
        , n_phase_term_drop_prsc = 1
!           Number of terms in the prescribed phase function for
!           droplets
      REAL  (RealK) :: &
          drop_pressure_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Pressures at which optical properties of
!           droplets are prescribed
        , drop_absorption_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, swdat%Dim%nd_band) &
!           Prescribed absorption by droplets
        , drop_scattering_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, swdat%Dim%nd_band) &
!           Prescribed scattering by droplets
        , drop_phase_fnc_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, swdat%Dim%nd_phase_term, swdat%Dim%nd_band)
!           Prescribed phase function of droplets
!     Ice crystals:
      INTEGER, Parameter :: &
          n_opt_level_ice_prsc = 1 &
!           Number of levels of prescribed
!           optical properties of ice crystals
        , n_phase_term_ice_prsc = 1
!           Number of terms in the prescribed phase function for
!           ice crystals
      REAL  (RealK) :: &
          ice_pressure_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Pressures at which optical properties of
!           ice crystals are prescribed
        , ice_absorption_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, swdat%Dim%nd_band) &
!           Prescribed absorption by ice crystals
        , ice_scattering_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, swdat%Dim%nd_band) &
!           Prescribed scattering by ice crystals
        , ice_phase_fnc_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, swdat%Dim%nd_phase_term, swdat%Dim%nd_band)
!           Prescribed phase functions of ice crystals
!
!     Aerosols:
      INTEGER :: &
          n_opt_level_aerosol_prsc(swdat%Dim%nd_aerosol_species) &
!           Number of levels of prescribed optical properties
!           of aerosols
        , n_phase_term_aerosol_prsc(swdat%Dim%nd_aerosol_species)
!           Number of terms in the prescribed phase functions
!           of aerosols
      REAL  (RealK) :: &
          aerosol_pressure_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, swdat%Dim%nd_aerosol_species) &
!           Pressures at which optical properties of aerosols
!           are prescribed
        , aerosol_absorption_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, swdat%Dim%nd_aerosol_species, swdat%Dim%nd_band) &
!           Prescribed absorption by aerosols
        , aerosol_scattering_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, swdat%Dim%nd_aerosol_species, swdat%Dim%nd_band) &
!           Prescribed scattering by aerosols
        , aerosol_phase_fnc_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc &
            , swdat%Dim%nd_phase_term, swdat%Dim%nd_aerosol_species, swdat%Dim%nd_band)
!           Prescribed phase functions of aerosols
!
!     Spectral region
      INTEGER, Parameter :: &
          isolir = IP_solar
!
!     Solar Fields
      REAL(RealK), ALLOCATABLE, DIMENSION(:) :: &
          solar_irrad &
!           Incident solar radiation
        , zen_0
!           Secants (two-stream) or cosines (sph) of solar zenith angles
!
!
!     Gaseous absorption
      INTEGER :: &
          i_gas_overlap(swdat%Dim%nd_band) &
!           Overlaps in each band
        , i_gas = 0
!           Species of gas to be read

      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          gas_mix_ratio
!           Mass mixing ratios of gases
!
!     Surface properties
      INTEGER, Parameter :: &
          n_brdf_basis_fnc = 2
!           Number of basis functions for BRDFs
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          rho_alb
!           Weights for basis functions of the BRDFs
      REAL  (RealK) :: &
          f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) = 1.0_r8
!           Array of BRDF basis terms
      REAL(RealK), ALLOCATABLE, DIMENSION(:) :: &
          t_ground
!           Temperature of the ground
!
!     Cloudy fields
      INTEGER :: &
!          i_cloud = IP_cloud_clear & !(must agree with i_solver)
          i_cloud = IP_cloud_triple &
!           Cloud scheme
        , n_condensed = 4 &
!           Number of condensed phases in clouds
        , condensed_n_phf(nd_cloud_component) = 1 &
!           Number of terms in the phase function for
!           condensed components
        , type_condensed(nd_cloud_component) &
!           Types of condensed phases in clouds
        , i_condensed_param(nd_cloud_component) &
!           Parametrization scheme for components
        , i_cloud_representation = IP_cloud_csiw &
!           Representation of the distribution of condensed
!           components between different types of cloud
        , n_cloud_type = 4
!           Number of types of clouds used
      REAL  (RealK), Parameter :: &
          dp_corr_strat = 0.0_r8 &
!           Decorrelation pressure scale for large scale cloud
        , dp_corr_conv = 0.0_r8 
!           Decorrelation pressure scale for convective cloud
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:) :: &
          w_cloud
!           Amounts of cloud
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          frac_cloud &
!           Fraction of each type of cloud
        , condensed_mix_ratio &
!           Mixing ratios of condensed components
        , condensed_dim_char
!           Characteristic dimensions of condensed components
      REAL  (RealK) :: &
          condensed_param_list(swdat%Dim%nd_cloud_parameter &
            , nd_cloud_component, swdat%Dim%nd_band)
!           Coefficients in the parametrizations of condensed phases
!
!hmjb: CLOUD FIELD
      REAL (RealK), ALLOCATABLE, DIMENSION(:,:,:) :: clouds
!
!     AEROSOL FIELDS
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          aerosol_mix_ratio
!           Mixing ratios of aserosols
!
!     Fluxes and radiances calculated
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          flux_direct &
!           Direct flux
        , flux_down &
!           Totol downward flux
        , flux_up &
!           Upward flux
        , flux_net &
!           Net flux
        , flux_direct_clear &
!           Clear-sky direct flux
        , flux_down_clear &
!           Clear-sky downward flux
        , flux_up_clear &
!           Clear-sky upward flux
        , flux_net_clear
!           Clear-sky Net flux

      REAL(RealK), DIMENSION(nd_j_profile, nd_viewing_level & 
           , nd_channel) :: photolysis
!           Calculated rates of photolysis
      REAL(RealK), DIMENSION(nd_radiance_profile, nd_viewing_level &
           , nd_direction, nd_channel) :: radiance
!           Radiances calculated


!     Dummy variables for use in calls to subroutines
!     (these are generally declared with the right shape
!     for bounds checking):
      INTEGER :: &
          i_dummy &
        , list_dummy(1) &
        , i_therm_dummy = 1
      REAL  (RealK) :: &
          wb_dummy(swdat%Dim%nd_band) &
        , ft_dummy(1, 1, nd_channel) &
        , tt_dummy(1, 1) &
        , rho_alb_dummy(1, nd_brdf_basis_fnc, 1, swdat%Dim%nd_band) &
        , therm_dummy(1, swdat%Dim%nd_band)

      !---------------------------------------------------------------------
      ! AUX VARIABLES 
      !---------------------------------------------------------------------

      integer :: nsol
      integer, dimension(ncols) :: listim,litx
      logical, dimension(ncols) :: bitx

      INTEGER      :: i  ! Loop variable
      INTEGER      :: j  ! Loop variable
      INTEGER      :: k  ! Loop variable

      INTEGER :: ntop 

      real :: aux

      !---------------------------------------------------------------------
      ! INITIALIZATION
      !---------------------------------------------------------------------
      ntop = 0
      HeatRate   = 0.0_r8
      HeatRateC = 0.0_r8

      ToaDown = 0.0_r8

      SfcVisBeamC = 0.0_r8
      SfcVisDiffC = 0.0_r8
      SfcNirBeamC = 0.0_r8
      SfcNirDiffC = 0.0_r8

      SfcVisBeam = 0.0_r8
      SfcVisDiff = 0.0_r8
      SfcNirBeam = 0.0_r8
      SfcNirDiff = 0.0_r8

      ToaNet  = 0.0_r8
      ToaNetC = 0.0_r8
      SfcNet  = 0.0_r8
      SfcNetC = 0.0_r8

      ierr = i_normal

      !---------------------------------------------------------------------------
      ! Check for daytime gridpoints
      !---------------------------------------------------------------------------

      ! SET ARRAY LISTIM = I, WHEN I=1,ncols
      FORALL (I=1:ncols) listim(I)=I

      ! set bits for daytime grid points
      ! BITX=.TRUE. IF COSZ>DUM(1)....0.01
      bitx(1:ncols)=cosz(1:ncols).ge.0.01e0_r8

      ! CALCULATE NSOL = NUMBER OF DAYTIME LATITUDE GRID POINTS
      nsol=COUNT(bitx(1:ncols))

      ! IF THERE ARE NO DAYTIME POINTS THEN RETURN
      IF (nsol == 0) RETURN

      ! SET INTEGER ARRAY LITX (NSOL)
      ! NUMBERS OF LATITUDE DAYTIME GRID POINTS AT 1st LEVEL, USING 
      ! INTEGER ARRAY LISTIM (NCOLS) = 1,2,....NCOLS
      litx=0
      litx(1:COUNT(bitx(1:ncols))) = PACK(listim(1:ncols), bitx(1:ncols))

      !---------------------------------------------------------------------------
      ! Assign sizes
      !---------------------------------------------------------------------------
      n_profile = nsol
      n_layer = kmax+ntop

      nd_profile = n_profile
      nd_layer = n_layer
      nd_layer_clr = n_layer
      nd_2sg_profile = n_profile
      nd_flux_profile = n_profile

      !---------------------------------------------------------------------------
      ! ALLOCATE MEMORY
      !---------------------------------------------------------------------------

      Allocate( pres    (nd_profile, nd_layer))
      pres = 0.0_r8
      Allocate( temp    (nd_profile, nd_layer))
      temp = 0.0_r8
      Allocate( d_mass  (nd_profile, nd_layer))
      d_mass = 0.0_r8
      Allocate( t_ground(nd_profile))
      t_ground = 0.0_r8
      Allocate( t_level (nd_profile, 0:nd_layer))
      t_level = 0.0_r8
      Allocate( zen_0      (nd_profile))
      zen_0 = 0.0_r8
      Allocate( solar_irrad(nd_profile))
      solar_irrad = 0.0_r8
      Allocate( rho_alb(nd_profile, nd_brdf_basis_fnc, swdat%Dim%nd_band))
      rho_alb = 0.0_r8

      Allocate( gas_mix_ratio(nd_profile, nd_layer, swdat%Dim%nd_species))
      gas_mix_ratio = 0.0_r8
      Allocate( aerosol_mix_ratio(nd_profile, nd_layer, swdat%Dim%nd_aerosol_species))
      aerosol_mix_ratio = 0.0_r8

      Allocate( w_cloud            (nd_profile, id_ct:nd_layer))
      w_cloud = 0.0_r8
      Allocate( frac_cloud         (nd_profile, id_ct:nd_layer, nd_cloud_type))
      frac_cloud = 0.0_r8
      Allocate( condensed_mix_ratio(nd_profile, id_ct:nd_layer, nd_cloud_component))
      condensed_mix_ratio = 0.0_r8
      Allocate( condensed_dim_char(nd_profile, id_ct:nd_layer, nd_cloud_component))
      condensed_dim_char = 0.0_r8

      Allocate( clouds(nd_profile, id_ct:nd_layer, nd_cloud_type))
      clouds = 0.0_r8

      Allocate( flux_direct(nd_profile, 0: nd_layer, nd_channel))
      flux_direct = 0.0_r8 
      Allocate( flux_down(nd_profile, 0: nd_layer, nd_channel))
      flux_down = 0.0_r8
      Allocate( flux_up(nd_profile, 0: nd_layer, nd_channel))
      flux_up = 0.0_r8
      Allocate( flux_net(nd_profile, 0: nd_layer, nd_channel))
      flux_net = 0.0_r8

      Allocate( flux_direct_clear(nd_2sg_profile,0:nd_layer,nd_channel))
      flux_direct_clear = 0.0_r8
      Allocate( flux_down_clear(nd_2sg_profile,0:nd_layer,nd_channel))
      flux_down_clear = 0.0_r8
      Allocate( flux_up_clear(nd_2sg_profile,0:nd_layer,nd_channel))
      flux_up_clear = 0.0_r8
      Allocate( flux_net_clear(nd_2sg_profile, 0: nd_layer, nd_channel))
      flux_net_clear = 0.0_r8
      !---------------------------------------------------------------------------
      ! Atmospheric Fields
      !---------------------------------------------------------------------------
      ! 
      DO i=1,nsol
         ! copy values to the end of the array
         DO k=ntop+1,nd_layer
            temp  (i,k) = Te (litx(i),k-ntop)
            d_mass(i,k) = DP(litx(i),k-ntop)*100.0_r8/grav_acc
            pres  (i,k) = Pmid (litx(i),k-ntop)*100.0_r8
         ENDDO
         
         ! split the highest layer into ntop+1 layers
         ! i.e. add ntop layers on top, but keep total mass constant
         DO k=1,ntop+1
            temp  (i,k) = Te (litx(i),1)
            d_mass(i,k) = DP(litx(i),1)*100.0_r8/grav_acc/(ntop+1)
            pres  (i,k) = (2.0_r8*k-1.0_r8)*DP(litx(i),1)*100.0_r8/(ntop+1)/2.0_r8
         ENDDO

         t_ground(i) = Tg(litx(i))

         ! We do not interpolate layer temperatures to find values at levels
         ! because de SW routines do not need such information
      ENDDO
      !---------------------------------------------------------------------------
      ! Solar fields
      !---------------------------------------------------------------------------
      ! Secant of zenith angle and solar constant at each grid point
      DO i=1,nsol
         zen_0(i) = 1.0_r8/cosz(litx(i))
         solar_irrad(i) = s0
      ENDDO

      ! band weigthing
      weight_band = 1.0_r8

      ! Method of treating scattering
      i_scatter_method = IP_scatter_full

      ! Mapping of the solar spectrum (six-bands) into two output bands (vis/nir)
      map_band_channel(1:3) = 1
      map_band_channel(4:6) = 2
         
      ! Overlaps in each band
      i_gas_overlap = IP_overlap_k_eqv
      !i_gas_overlap = IP_overlap_random !hmjb: extremely slow

      !---------------------------------------------------------------------------
      ! Mixing ratios of gases considered 
      !---------------------------------------------------------------------------
      ! Note: This configuration relies on the order that the gases have been
      ! defined in the spectral file. So, if the spectral file is changed, this
      ! definition below (i.e. 1=h20, 2=co2, 3=o3, 4=o2) must be changed 
      ! accordingly
      if (l_gas) then
         DO i=1,nsol
            DO k=ntop+1,nd_layer
               ! 1. Water vapour
               gas_mix_ratio(i,k,1) = Qe(litx(i),k-ntop)/(1.0_r8-Qe(litx(i),k-ntop)) 
               ! 2. Carbon dioxide
               gas_mix_ratio(i,k,2) = co2val*(CO2_mol_mass/dryair_mol_mass)*1.0e-06_r8
               ! 3. Ozone
               gas_mix_ratio(i,k,3) = O3 (litx(i),k-ntop)
               ! 4. Oxigen
               gas_mix_ratio(i,k,4) = 0.20946_r8*(O2_mol_mass/dryair_mol_mass)
            ENDDO
            
            ! repeat values in the extra layers
            do j=1,4
               gas_mix_ratio(i,1:ntop,j) = gas_mix_ratio(i,ntop+1,j)
            enddo

         ENDDO

      endif

      ! Doppler broadening
      l_doppler = .false.
      doppler_correction = 0.0_r8

      !---------------------------------------------------------------------------
      ! Surface fields
      !---------------------------------------------------------------------------
      ! Set surface albedo for each band based only on the two values provided by
      ! the AGCM: visible and near infrared. If a new surface scheme gives a 
      ! better representation of albedo, this should be passed in here.
      rho_alb=0.0_r8
      DO i=1,nsol
         DO j=1,swdat%Dim%nd_band
            IF(map_band_channel(j).eq.1) THEN
               rho_alb(i,IP_surf_alb_diff,j) = AlbVisDiff(litx(i))
               rho_alb(i,IP_surf_alb_dir,j) = AlbVisBeam(litx(i))
            ELSE
               rho_alb(i,IP_surf_alb_diff,j) = AlbNirDiff(litx(i))
               rho_alb(i,IP_surf_alb_dir,j) = AlbNirBeam(litx(i))
            ENDIF
         ENDDO
      ENDDO

      !---------------------------------------------------------------------------
      ! Aerosols
      !---------------------------------------------------------------------------
      !
      aerosol_mix_ratio = 0.0_r8
      ! consider only the first 5 aerosols in the list which correspond
      ! to the 5 climatological aerosols, and are the ones that we specify here
      if (l_aerosol) then
         do i=1,nsol
            if (imask(litx(i)).le.0_i8.or.imask(litx(i)).eq.13_i8) then
               aerosol_mix_ratio(i,ntop+1    :ntop+nls ,1:5) = aerosol_clim_ocean(1:nls     ,1:5)/Pbot(litx(i),kmax)/100.0_r8
               aerosol_mix_ratio(i,ntop+nls+1:nd_layer ,1:5) = aerosol_clim_ocean(nls+1:kMax,1:5)
            else
               aerosol_mix_ratio(i,ntop+1    :ntop+nls ,1:5) = aerosol_clim_land (1:nls     ,1:5)/Pbot(litx(i),kmax)/100.0_r8
               aerosol_mix_ratio(i,ntop+nls+1:nd_layer ,1:5) = aerosol_clim_land (nls+1:kMax,1:5)
            endif
            aerosol_mix_ratio(i,1:ntop,1) = aerosol_mix_ratio(i,ntop+1,1)
            aerosol_mix_ratio(i,1:ntop,2) = aerosol_mix_ratio(i,ntop+1,2)
            aerosol_mix_ratio(i,1:ntop,3) = aerosol_mix_ratio(i,ntop+1,3)
            aerosol_mix_ratio(i,1:ntop,4) = aerosol_mix_ratio(i,ntop+1,4)
            aerosol_mix_ratio(i,1:ntop,5) = aerosol_mix_ratio(i,ntop+1,5)
         enddo
      endif

      !---------------------------------------------------------------------------
      ! Clouds
      !---------------------------------------------------------------------------

      !---------------------------------------------------------------------------
      ! Cloud parameters and definitions
      type_condensed(1) = IP_clcmp_st_water  ! stratiform water droplets
      type_condensed(2) = IP_clcmp_st_ice    ! stratiform ice crystals
      type_condensed(3) = IP_clcmp_cnv_water ! convective water droplets
      type_condensed(4) = IP_clcmp_cnv_ice   ! convective ice crystals

      i_condensed_param(1) = swdat%Drop%i_drop_parm(5)
      i_condensed_param(2) = swdat%Ice%i_ice_parm  (8)
      i_condensed_param(3) = swdat%Drop%i_drop_parm(5)
      i_condensed_param(4) = swdat%Ice%i_ice_parm  (8)

      DO i=1,swdat%Dim%nd_cloud_parameter
         DO k=1,swdat%Dim%nd_band
            condensed_param_list(i,1,k) = swdat%Drop%parm_list(i,k,5) ! st water  
            condensed_param_list(i,2,k) =  swdat%Ice%parm_list(i,k,8) ! st ice    
            condensed_param_list(i,3,k) = swdat%Drop%parm_list(i,k,5) ! conv water
            condensed_param_list(i,4,k) =  swdat%Ice%parm_list(i,k,8) ! conv ice  
         ENDDO
      ENDDO

      !---------------------------------------------------------------------------
      ! Cloud Cover
      if (l_cloud) then
         DO i=1,nsol
            DO k=ntop+id_ct,nd_layer
               clouds(i,k,IP_cloud_type_sw) = cld(litx(i),k-ntop) * (1.0_r8-fice(litx(i),k-ntop)) ! st water
               clouds(i,k,IP_cloud_type_si) = cld(litx(i),k-ntop) *      fice(litx(i)   ,k-ntop)  ! st ice
               clouds(i,k,IP_cloud_type_cw) = clu(litx(i),k-ntop) * (1.0_r8-fice(litx(i),k-ntop)) ! conv water
               clouds(i,k,IP_cloud_type_ci) = clu(litx(i),k-ntop) *      fice(litx(i)   ,k-ntop)  ! conv ice
            end do
            ! repeat values
            clouds(i,1:ntop,IP_cloud_type_sw) = clouds(i,ntop+1,IP_cloud_type_sw)
            clouds(i,1:ntop,IP_cloud_type_si) = clouds(i,ntop+1,IP_cloud_type_si)
            clouds(i,1:ntop,IP_cloud_type_cw) = clouds(i,ntop+1,IP_cloud_type_cw)
            clouds(i,1:ntop,IP_cloud_type_ci) = clouds(i,ntop+1,IP_cloud_type_ci)
         end do
         
         DO i=1,nsol
            DO k=id_ct,nd_layer
               ! random overlap within each layer (mixing components)
               w_cloud(i,k) = 1.0_r8
               aux = 0.0_r8
               do j=1,n_condensed
                  w_cloud(i,k) = w_cloud(i,k)*(1-clouds(i,k,j))
                  aux = aux + clouds(i,k,j)
               enddo
               ! after summing, we should have aux = cld+clu
               w_cloud(i,k) = 1.0_r8 - w_cloud(i,k)
               !w_cloud(i,k) = aux ! this can be >1.0_r8
               
               ! not easy to calculate fractions without overlap, since 
               ! our clouds do overlap. for now, we take fractions of the sum
               IF (aux.GT.0.0_r8) frac_cloud(i,k,:) = clouds(i,k,:)/aux
            ENDDO
         ENDDO
      endif

      !---------------------------------------------------------------------------
      ! Mixing ratio of Water and Ice
      condensed_mix_ratio=0.0_r8
      condensed_dim_char=0.0_r8
      DO i=1,nsol
         DO k=ntop+id_ct,nd_layer
            condensed_mix_ratio(i,k,IP_cloud_type_sw) = lmixr(litx(i),k-ntop)*(1.0_r8-fice(litx(i),k-ntop))! st water  
            condensed_mix_ratio(i,k,IP_cloud_type_si) = lmixr(litx(i),k-ntop)*fice(litx(i),k-ntop)    ! st ice    
            condensed_mix_ratio(i,k,IP_cloud_type_cw) = lmixr(litx(i),k-ntop)*(1.0_r8-fice(litx(i),k-ntop))! conv water
            condensed_mix_ratio(i,k,IP_cloud_type_ci) = lmixr(litx(i),k-ntop)*fice(litx(i),k-ntop)    ! conv ice  

            condensed_dim_char(i,k,IP_cloud_type_sw)=rel(litx(i),k-ntop)*1.e-6_r8 ! st water  
            condensed_dim_char(i,k,IP_cloud_type_si)=rei(litx(i),k-ntop)*1.e-6_r8 ! st ice    
            condensed_dim_char(i,k,IP_cloud_type_cw)=rel(litx(i),k-ntop)*1.e-6_r8 ! conv water
            condensed_dim_char(i,k,IP_cloud_type_ci)=rei(litx(i),k-ntop)*1.e-6_r8 ! conv ice  
         ENDDO

         ! repeat values
         condensed_mix_ratio(i,1:ntop,IP_cloud_type_sw)= &
              condensed_mix_ratio(i,ntop+1,IP_cloud_type_sw)
         condensed_mix_ratio(i,1:ntop,IP_cloud_type_si)= &
              condensed_mix_ratio(i,ntop+1,IP_cloud_type_si)
         condensed_mix_ratio(i,1:ntop,IP_cloud_type_cw)= &
              condensed_mix_ratio(i,ntop+1,IP_cloud_type_cw)
         condensed_mix_ratio(i,1:ntop,IP_cloud_type_ci)= &
              condensed_mix_ratio(i,ntop+1,IP_cloud_type_ci)

         condensed_dim_char (i,1:ntop,IP_cloud_type_sw)= &
              condensed_dim_char (i,ntop+1,IP_cloud_type_sw)
         condensed_dim_char (i,1:ntop,IP_cloud_type_si)= &
              condensed_dim_char (i,ntop+1,IP_cloud_type_si)
         condensed_dim_char (i,1:ntop,IP_cloud_type_cw)= &
              condensed_dim_char (i,ntop+1,IP_cloud_type_cw)
         condensed_dim_char (i,1:ntop,IP_cloud_type_ci)= &
              condensed_dim_char (i,ntop+1,IP_cloud_type_ci)

      ENDDO

      !---------------------------------------------------------------------------
      ! CALCULATE RADIANCES OR IRRADIANCES
      !---------------------------------------------------------------------------

      CALL radiance_calc(ierr &
           !                       Logical Flags for Processes
           , l_rayleigh, l_aerosol, l_gas, l_continuum &
           , l_cloud, l_drop, l_ice &
           !                       Angular Integration
           , i_angular_integration, l_rescale, n_order_forward &
           , i_2stream &
           , n_order_gauss &
           , i_truncation, ls_global_trunc, ms_min, ms_max &
           , accuracy_adaptive, euler_factor &
           , l_henyey_greenstein_pf, ls_brdf_trunc &
           , i_sph_algorithm, n_order_phase_solar &
           , n_direction, direction &
           , n_viewing_level, viewing_level, i_sph_mode  &
           !                       Treatment of Scattering
           , i_scatter_method &
           !                       Options for treating clouds
           , l_global_cloud_top, n_global_cloud_top &
           !                       Options for Solver
           , i_solver &
           !                       Properties of diagnostics
           , map_band_channel &
           !                       General Spectral Properties
           , swdat%Dim%nd_band, nmin, nmax, weight_band &
           !                       General Atmospheric Properties
           , n_profile, n_layer, pres, temp &
           , t_ground, t_level, d_mass &
           !                       Spectral Region
           , isolir &
           !                       Solar Fields
           , zen_0, solar_irrad, swdat%Solar%solar_flux_band &
           , swdat%Rayleigh%rayleigh_coeff &
           !                       Infra-red Fields        
           , swdat%Planck%n_deg_fit, therm_dummy, swdat%Planck%t_ref_planck &
           , l_ir_source_quad &
           !                       Gaseous Absorption
           , i_gas_overlap, i_gas &
           , gas_mix_ratio, swdat%Gas%n_band_absorb, swdat%Gas%index_absorb &
           , swdat%Gas%i_band_k, swdat%Gas%w, swdat%Gas%k, swdat%Gas%i_scale_k &
           , swdat%Gas%i_scale_fnc, swdat%Gas%scale &
           , swdat%Gas%p_ref, swdat%Gas%t_ref &
           !                       Doppler Broadening
           , l_doppler, doppler_correction &
           !                       Surface Fields
           , n_brdf_basis_fnc, rho_alb, f_brdf &
           !                       Tiling options for heterogeneous surfaces 
           , .false., i_dummy, i_dummy, list_dummy &
           , rho_alb_dummy, tt_dummy, tt_dummy &
           !                       Continuum Absorption
           , swdat%Cont%n_band_continuum, swdat%Cont%index_continuum, swdat%Cont%index_water &
           , swdat%Cont%k_cont, swdat%Cont%i_scale_fnc_cont, swdat%Cont%scale_cont &
           , swdat%Cont%p_ref_cont, swdat%Cont%t_ref_cont &
           !                       Properties of Aerosols
           , swdat%Aerosol%n_aerosol, aerosol_mix_ratio &
           , swdat%Aerosol%abs, swdat%Aerosol%scat  &
           , swdat%Aerosol%n_aerosol_phf_term, swdat%Aerosol%phf_fnc &
           , swdat%Aerosol%i_aerosol_parm, swdat%Aerosol%nhumidity, swdat%Aerosol%humidities &
           , n_opt_level_aerosol_prsc, n_phase_term_aerosol_prsc &
           , aerosol_pressure_prsc, aerosol_absorption_prsc &
           , aerosol_scattering_prsc, aerosol_phase_fnc_prsc &
           !                       Properties of Clouds
           , n_condensed, type_condensed &
           , i_cloud, i_cloud_representation, w_cloud &
           , n_cloud_type, frac_cloud &
           , condensed_mix_ratio, condensed_dim_char &
           , i_condensed_param, condensed_n_phf, condensed_param_list &
           , dp_corr_strat, dp_corr_conv &
           , n_opt_level_drop_prsc, n_phase_term_drop_prsc &
           , drop_pressure_prsc, drop_absorption_prsc &
           , drop_scattering_prsc, drop_phase_fnc_prsc &
           , n_opt_level_ice_prsc, n_phase_term_ice_prsc &
           , ice_pressure_prsc, ice_absorption_prsc &
           , ice_scattering_prsc, ice_phase_fnc_prsc &
           !                       Fluxes Calculated
           , flux_direct, flux_down, flux_up &
           , radiance, photolysis &
           !                       Options for Clear-sky Fluxes
           , l_clear, i_solver_clear &
           !                       Clear-sky Fluxes Calculated
           , flux_direct_clear, flux_down_clear, flux_up_clear   &
           !                       Special Surface Fluxes
           , .false., wb_dummy, tt_dummy, tt_dummy, tt_dummy &
           !                       Tiled Surface Fluxes
           , ft_dummy, ft_dummy &
           !                       Dimensions of Arrays
           , nd_profile, nd_layer, nd_column, nd_layer, id_ct &
           , nd_2sg_profile, nd_flux_profile &
           , nd_radiance_profile, nd_j_profile &
           , nd_channel, swdat%Dim%nd_band &
           , swdat%Dim%nd_species, nd_esft_term, swdat%Dim%nd_scale_variable &
           , swdat%Dim%nd_continuum &
           , swdat%Dim%nd_aerosol_species, swdat%Dim%nd_humidity &
           , swdat%Dim%nd_cloud_parameter &
           , i_therm_dummy, nd_source_coeff &
           , nd_brdf_basis_fnc, nd_brdf_trunc &
           , nd_profile_aerosol_prsc, nd_profile_cloud_prsc &
           , nd_opt_level_aerosol_prsc, nd_opt_level_cloud_prsc &
           , swdat%Dim%nd_phase_term, nd_max_order, nd_sph_coeff &
           , nd_direction, nd_viewing_level &
           , nd_region, nd_cloud_type, nd_cloud_component &
           , nd_overlap_coeff &
           , nd_point_tile, nd_tile &
           )

      if (ierr/=0) stop

      ! Net flux at the interfaces
      DO i=1, nsol
         DO k=0, nd_layer
            DO j=1, nd_channel 
               flux_net(i,k,j)        = flux_down(i,k,j)       - flux_up(i,k,j)
               flux_net_clear(i,k,j)  = flux_down_clear(i,k,j) - flux_up_clear(i,k,j)
            ENDDO
         ENDDO
      ENDDO

      !---------------------------------------------------------------------------
      ! Convert available radiance_calc output to necessary swrad output
      !---------------------------------------------------------------------------
      ! Channel 1 = Visible
      ! Channel 2 = Near Infrared

      !---------------------------------------------------------------------------
      ! Surface and TOA come from the fluxes at the interfaces
      DO i=1,nsol
         DO j=1,nd_channel
            ToaDown(litx(i))  = ToaDown(litx(i)) + flux_down(i,0,j)
            ToaNet (litx(i))  = ToaNet (litx(i)) + flux_net(i,0,j)
            ToaNetC(litx(i))  = ToaNetC(litx(i)) + flux_net_clear(i,0,j)
             
            SfcNet (litx(i))  = SfcNet (litx(i)) + flux_net(i,nd_layer,j)
            SfcNetC(litx(i))  = SfcNetC(litx(i)) + flux_net_clear(i,nd_layer,j)
         ENDDO
         ! We also need the NIR and VIS separately ...
         ! and also the diffuse and direct for the vegetation scheme
         SfcVisBeamC(litx(i)) = flux_direct_clear(i,nd_layer,1)
         SfcVisDiffC(litx(i)) = flux_down_clear(i,nd_layer,1) - flux_direct_clear(i,nd_layer,1)
         SfcNirBeamC(litx(i)) = flux_direct_clear(i,nd_layer,2)
         SfcNirDiffC(litx(i)) = flux_down_clear(i,nd_layer,2) - flux_direct_clear(i,nd_layer,2)
         !
         SfcVisBeam(litx(i)) = flux_direct(i,nd_layer,1)
         SfcVisDiff(litx(i)) = flux_down(i,nd_layer,1) - flux_direct(i,nd_layer,1)
         SfcNirBeam(litx(i)) = flux_direct(i,nd_layer,2)
         SfcNirDiff(litx(i)) = flux_down(i,nd_layer,2) - flux_direct(i,nd_layer,2)
      ENDDO

      !-----------------------------------------------------------------------
      ! Solar Heating Rate. the model expect K/s
      !-----------------------------------------------------------------------

      ! We are loosing the heating in the extra layer at the top of the atmosphere. 
      ! This used to be done in old radiation codes, for avoiding a very large 
      ! value at the top that would make the model unstable. Need to check if 
      ! that's necessary with kmax>=28
      DO i=1,nsol
         DO k=1,kmax
            DO j=1,nd_channel
               HeatRate(litx(i),k)   = HeatRate(litx(i),k)                          &
                    + (flux_net(i,ntop+k-1,j)-flux_net(i,ntop+k,j))/                &
                    (d_mass(i,ntop+k)*cp_air_dry)

               HeatRateC(litx(i),k) = HeatRateC(litx(i),k) &
                    + (flux_net_clear(i,ntop+k-1,j)-flux_net_clear(i,ntop+k,j))/    &
                    (d_mass(i,ntop+k)*cp_air_dry)
            ENDDO
         ENDDO
      ENDDO
      !---------------------------------------------------------------------------
      ! DEALLOCATE MEMORY
      !---------------------------------------------------------------------------

      Deallocate( pres )
      Deallocate( temp )
      Deallocate( d_mass )
      Deallocate( t_ground )
      Deallocate( t_level )
      Deallocate( zen_0 )
      Deallocate( solar_irrad )
      Deallocate( rho_alb )

      Deallocate( gas_mix_ratio )
      Deallocate( aerosol_mix_ratio )

      Deallocate( w_cloud )
      Deallocate( frac_cloud )
      Deallocate( condensed_mix_ratio )
      Deallocate( condensed_dim_char )
      Deallocate( clouds )

      Deallocate( flux_direct )
      Deallocate( flux_down )
      Deallocate( flux_up )
      Deallocate( flux_net )

      Deallocate( flux_direct_clear )
      Deallocate( flux_down_clear )
      Deallocate( flux_up_clear )
      Deallocate( flux_net_clear )

      RETURN
  END SUBROUTINE ukmo_swintf

  ! LWINTF ("LongWave INTerFace")
  ! to replace LWRAD into the global model
  ! (using nearly the same input and output, with additions, when necessary),
  ! to call RADIANCE_CALC (calculates SW fluxes).
  ! 
  ! RADIANCE_CALC is the main routine of the Edwards & Slingo radiation code.
  !
  ! Authors: Julio Chagas & Henrique Barbosa
  !
  !---------------------------------------------------------------------------
  SUBROUTINE ukmo_lwintf( &
       ! Model Info and flags
       ncols         ,kmax      ,                             &
       ! Atmospheric fields
       Pbot          ,Pmid      ,DP            ,Te          , &
       Qe            ,O3        ,co2val        ,Tg          , &
       ! SURFACE
       imask         ,                                        &
       ! LW Radiation fields 
       lw_toa_up_clr ,lw_toa_up ,lw_cool_clr    ,lw_cool    , &
       lw_sfc_net_clr,lw_sfc_net,lw_sfc_down_clr,lw_sfc_down, &
       ! Cloud field
       cld           ,clu       ,fice           ,             &
       rei           ,rel       ,lmixr                          )

      USE ESRAD, only: radiance_calc

      USE Init, only: nls

      IMPLICIT NONE

      !---------------------------------------------------------------------------
      ! INPUT VARIABLES
      !---------------------------------------------------------------------------

      ! Number of atmospheric columns to solve
      INTEGER, INTENT(in) :: ncols
      ! Number of atmospheric levels
      INTEGER, INTENT(in) :: kmax

      ! Ground surface temperature (K)
      REAL(KIND=r8), DIMENSION(ncols), INTENT(in) :: Tg

      REAL(KIND=r8), DIMENSION(ncols,kmax), INTENT(in) :: &
           ! Pressure at bottom of layers (mb)
             Pbot &
           ! Pressure at Middle of Layer(mb)
           , Pmid &
           ! Pressure difference bettween levels (mb)
           , DP &
           ! Temperature at middle of Layer (K)
           , Te &
           ! Specific Humidity at middle of layer (g/g)
           , Qe &
           ! Ozone Mixing ratio at middle of layer (g/g)
           , O3 &
           ! Large scale cloud amount in layers
           , cld &
           ! Cumulus cloud amount in layers
           , clu &
           ! fractional amount of cloud that is ice
           , fice &
           ! Ice particle Effective Radius (microns)
           , rei &
           ! Liquid particle Effective Radius (microns)
           , rel &
           ! ice/water mixing ratio
           , lmixr

      ! co2 concentration in ppmv(??)
      REAL(KIND=r8), INTENT(in) :: co2val

      ! vegetagion mask (0=ocean, -1=sea ice and 13=land ice)
      INTEGER(KIND=i8), INTENT(IN) :: imask (ncols)

      !---------------------------------------------------------------------------
      ! OUTPUT VARIABLES
      !---------------------------------------------------------------------------

      REAL(KIND=r8), DIMENSION(ncols), INTENT(inout) :: &
           ! Upward TOA longwave flux (clear)
             lw_toa_up_clr &
           ! Upward TOA longwave flux
           , lw_toa_up &
           ! Net Surface longwave flux (clear)
           , lw_sfc_net_clr &
           ! Net Surface longwave flux
           , lw_sfc_net &
           ! Downward Surface longwave flux (clear)
           , lw_sfc_down_clr &
           ! Downward Surface longwave flux
           , lw_sfc_down

      REAL(KIND=r8), DIMENSION(ncols,kmax), INTENT(inout) :: &
           ! Cooling rate (K/s, clear)
             lw_cool_clr &
           ! Cooling rate (K/s)
           , lw_cool

      !---------------------------------------------------------------------------
      ! ESRAD CONFIGURATION and VARIABLES
      !---------------------------------------------------------------------------

!     Treatment of errors:
      INTEGER &
          ierr
!           Error flag
!
!     Derived dimensions:
      INTEGER :: &
          nd_profile &
!           Size allocated for atmospheric profiles
        , nd_layer &
!           Size allocated for atmospheric layers
        , nd_layer_clr &
!           Size allocated for totally clear layers
        , nd_2sg_profile &
!           Number of profiles in arrays of fluxes
        , nd_flux_profile
!           Number of profiles in arrays of output fluxes

      INTEGER, PARAMETER :: &
          nd_radiance_profile = 1 &
!           Number of profiles in arrays of radiances
        , nd_j_profile = 1 &
!           Number of profiles in arrays of mean radiances
        , id_ct = 1 &
!           Topmost declared cloudy layer
        , nd_channel = 1 &
!           Size allocated for profiles of radiances
        , nd_esft_term = 25 &
!           Size allocated for ESFT terms
        , nd_source_coeff = 2 &
!           Size allocated for two-stream source coefficients
        , nd_brdf_basis_fnc = 2 &
!           Size allocated for BRDF basis functions
        , nd_brdf_trunc = 5 &
!           Size allocated for BRDF truncation
        , nd_column = 1 &
!           Size allocated for columns at each grid-point
        , nd_max_order = 1 &
!           Size allocated for polar orders
        , nd_direction = 1 &
!           Size allocated for viewing directions at each point
        , nd_viewing_level = 1 &
!           Size allocated for levels where the radiance may be calculated
        , nd_cloud_type = 4 &
!           Size allocated for types of clouds
        , nd_cloud_component = 4 &
!           Size allocated for components in clouds
        , nd_overlap_coeff = 18 &
!           Size allocated for overlap coefficients
        , nd_sph_coeff = 1 &
!           Size allocated for arrays of spherical coeff used in determining radiances
        , nd_point_tile = 1 &
!           Size allocated for points with surface tiling
        , nd_tile = 1 &
!           Size allocated for the number of tiles
        , nd_region = 3
!           Size allocated for ice crystal types
!
!           Name of spectral file
      INTEGER, PARAMETER :: &
          nmin = 1 &
!           Sorted first band
        , nmax = 9
!           Sorted last band
      REAL  (RealK) :: &
          weight_band(lwdat%Dim%nd_band)
!           Weights for each band
!
!
!     Physical processes included
      LOGICAL, PARAMETER :: &
          l_rayleigh = .false. &
!           Flag for Rayleigh scattering
        , l_aerosol = .true. &
!           Flag for the direct effects of aerosols
        , l_gas = .true. &
!           Flag for gaseous absorption
        , l_continuum = .true. &
!           Flag for continuum absorption
        , l_drop = .true. &
!           Flag for water droplets
        , l_ice = .true. &
!           Flag for ice crystals
        , l_cloud = .true. &
!           Flag for cloud processes
        , l_global_cloud_top = .true.
!           Use a global value for the top of clouds
!           (This is for use in a GCM where the code must be
!           bit-reproducible across different configurations of PEs).
      LOGICAL :: &
          l_doppler(lwdat%Dim%nd_species)
!           Flag for Doppler broadening
      INTEGER, PARAMETER :: &
          n_global_cloud_top = 1
!           Global cloud top
!
       ! Doppler correction terms
      REAL (RealK) :: doppler_correction(lwdat%Dim%nd_species)
!
!     Angular integration
      INTEGER, PARAMETER :: &
          i_angular_integration = IP_two_stream &
!           Type of angular integration
        , i_2stream = IP_elsasser &
!           Type of two-stream scheme
        , n_order_gauss = 0 &
!           Order of Gaussian integration (IR only)
        , i_truncation = 0 &
!           Type of truncation
        , ls_global_trunc = 0 &
!           Overall order of truncation with spherical harmonics
        , ms_min = 0 &
!           Lowest azimuthal order calculated
        , ms_max = 0 &
!           Highest azimuthal order calculated
        , ls_brdf_trunc = 0 &
!           Order of truncation applied to BRDFs
        , n_order_forward = 2 &
!           Order of term used to `define'' the
!           forward scattering fraction
        , i_sph_mode = 0 &
!           Mode in which the spherical solver is used
        , i_sph_algorithm = 0 &
!           Algorithm used for spherical harmonic calculation
        , n_order_phase_solar = 1
!           Number of terms in the phase function used for
!           singly scattered solar radiation in an iterative
!           solution
      LOGICAL, PARAMETER :: &
          l_rescale = .true. &
!           Flag for rescaling of the phase function
        , l_ir_source_quad = .true. & !hmjb  see umdp_rad_main.pdf, section 2.3
!           Flag to use a quadratic source function in the IR
        , l_henyey_greenstein_pf = .true.
!           Flag for Henyey-Greenstein phase functions
! hmjb henyey should be true if rescale=true (see angular_control_cdf.f)
      REAL  (RealK), PARAMETER :: &
          accuracy_adaptive = 0.0_r8 &
!           Accuracy used for adaptive truncation
        , euler_factor = 0.0_r8
!           Factor applied to the last term of an alternating series
!
!     Treatment of scattering
      INTEGER :: &
          i_scatter_method(lwdat%Dim%nd_band)
!           Method of treating scattering
!
!     Viewing geometry
      INTEGER, PARAMETER :: &
          n_direction = 0 
!           Number of viewing directions
      REAL(RealK), DIMENSION(nd_radiance_profile, nd_direction, 2) :: &
          direction
!           Viewing angles
!
!     Levels of viewing
      INTEGER, PARAMETER :: &
          n_viewing_level = 0
!           Number of levels where radiances are required
      REAL(RealK), DIMENSION(nd_viewing_level) :: &
          viewing_level
!           List of required levels: space is allocated so that
!           either radiances or fluxes may be calculated
!
!     Ouput properties:
      INTEGER :: &
          map_band_channel(lwdat%Dim%nd_band)
!           Mapping of spectral bands to channels
!
!     Options for solvers:
      LOGICAL, PARAMETER :: &
          l_clear = .true.
!           Solve for clear-sky fluxes as well as cloudy fluxes
      INTEGER, PARAMETER :: &
!          i_solver = IP_solver_homogen_direct& !(must agree with i_cloud)
          i_solver = IP_solver_triple &
!          i_solver = IP_solver_triple_app_scat &
!           Type of main solver
        , i_solver_clear = IP_solver_homogen_direct
!           Type of solver for clear-sky fluxes
!
!     General atmospheric properties
      INTEGER :: &
          n_profile &
!           Number of profiles
        , n_layer
!           Number of layers
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:) :: &
          pres &
!           Pressures in layers
        , temp &
!           Temperatures in layers
        , t_level &
!           Temperatures at the boundaries of layers
        , d_mass
!           Masses in layers
!
!     Prescribed optical properties
!
      INTEGER, Parameter :: nd_profile_aerosol_prsc = 1
!       Size allocated for profiles of prescribed
!       cloudy optical properties
      INTEGER, Parameter :: nd_profile_cloud_prsc = 1
!       Size allocated for profiles of prescribed
!       aerosol optical properties
      INTEGER, Parameter :: nd_opt_level_aerosol_prsc = 1
!       Size allocated for levels of prescribed
!       cloudy optical properties
      INTEGER, Parameter :: nd_opt_level_cloud_prsc = 1
!       Size allocated for levels of prescribed
!       aerosol optical properties

!     Droplets:
      INTEGER, Parameter :: &
          n_opt_level_drop_prsc = 1 &
!           Number of levels of prescribed
!           optical properties of droplets
        , n_phase_term_drop_prsc = 1
!           Number of terms in the prescribed phase function for
!           droplets
      REAL  (RealK) :: &
          drop_pressure_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Pressures at which optical properties of
!           droplets are prescribed
        , drop_absorption_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, lwdat%Dim%nd_band) &
!           Prescribed absorption by droplets
        , drop_scattering_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, lwdat%Dim%nd_band) &
!           Prescribed scattering by droplets
        , drop_phase_fnc_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, lwdat%Dim%nd_phase_term, lwdat%Dim%nd_band)
!           Prescribed phase function of droplets
!     Ice crystals:
      INTEGER, Parameter :: &
          n_opt_level_ice_prsc = 1 &
!           Number of levels of prescribed
!           optical properties of ice crystals
        , n_phase_term_ice_prsc = 1
!           Number of terms in the prescribed phase function for
!           ice crystals
      REAL  (RealK) :: &
          ice_pressure_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc) &
!           Pressures at which optical properties of
!           ice crystals are prescribed
        , ice_absorption_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, lwdat%Dim%nd_band) &
!           Prescribed absorption by ice crystals
        , ice_scattering_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, lwdat%Dim%nd_band) &
!           Prescribed scattering by ice crystals
        , ice_phase_fnc_prsc(nd_profile_cloud_prsc &
            , nd_opt_level_cloud_prsc, lwdat%Dim%nd_phase_term, lwdat%Dim%nd_band)
!           Prescribed phase functions of ice crystals
!
!     Aerosols:
      INTEGER :: &
          n_opt_level_aerosol_prsc(lwdat%Dim%nd_aerosol_species) &
!           Number of levels of prescribed optical properties
!           of aerosols
        , n_phase_term_aerosol_prsc(lwdat%Dim%nd_aerosol_species)
!           Number of terms in the prescribed phase functions
!           of aerosols
      REAL  (RealK) :: &
          aerosol_pressure_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, lwdat%Dim%nd_aerosol_species) &
!           Pressures at which optical properties of aerosols
!           are prescribed
        , aerosol_absorption_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, lwdat%Dim%nd_aerosol_species, lwdat%Dim%nd_band) &
!           Prescribed absorption by aerosols
        , aerosol_scattering_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc, lwdat%Dim%nd_aerosol_species, lwdat%Dim%nd_band) &
!           Prescribed scattering by aerosols
        , aerosol_phase_fnc_prsc(nd_profile_aerosol_prsc &
            , nd_opt_level_aerosol_prsc &
            , lwdat%Dim%nd_phase_term, lwdat%Dim%nd_aerosol_species, lwdat%Dim%nd_band)
!           Prescribed phase functions of aerosols
!
!     Spectral region
      INTEGER, Parameter :: &
          isolir = IP_infra_red
!
!     Solar Fields
      REAL(RealK), ALLOCATABLE, DIMENSION(:) :: &
          solar_irrad &
!           Incident solar radiation
        , zen_0
!           Secants (two-stream) or cosines (sph) of solar zenith angles
!
!
!     Gaseous absorption
      INTEGER :: &
          i_gas_overlap(lwdat%Dim%nd_band) &
!           Overlaps in each band
        , i_gas = 0
!           Species of gas to be read

      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          gas_mix_ratio
!           Mass mixing ratios of gases
!
!     Surface properties
      INTEGER, Parameter :: &
          n_brdf_basis_fnc = 1
!           Number of basis functions for BRDFs
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          rho_alb
!           Weights for basis functions of the BRDFs
      REAL  (RealK) :: &
          f_brdf(nd_brdf_basis_fnc, 0: nd_brdf_trunc/2 &
            , 0: nd_brdf_trunc/2, 0: nd_brdf_trunc) = 0.0_r8
!           Array of BRDF basis terms
      REAL(RealK), ALLOCATABLE, DIMENSION(:) :: &
          t_ground
!           Temperature of the ground
!
!     Cloudy fields
      INTEGER :: &
!          i_cloud = IP_cloud_clear & !(must agree with i_solver)
          i_cloud = IP_cloud_triple &
!           Cloud scheme
        , n_condensed = 4 &
!           Number of condensed phases in clouds
        , condensed_n_phf(nd_cloud_component) = 1 &
!           Number of terms in the phase function for
!           condensed components
        , type_condensed(nd_cloud_component) &
!           Types of condensed phases in clouds
        , i_condensed_param(nd_cloud_component) &
!           Parametrization scheme for components
        , i_cloud_representation = IP_cloud_csiw &
!           Representation of the distribution of condensed
!           components between different types of cloud
        , n_cloud_type = 4
!           Number of types of clouds used
      REAL  (RealK), Parameter :: &
          dp_corr_strat = 0.0_r8 &
!           Decorrelation pressure scale for large scale cloud
        , dp_corr_conv = 0.0_r8 
!           Decorrelation pressure scale for convective cloud
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:) :: &
          w_cloud
!           Amounts of cloud
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          frac_cloud &
!           Fraction of each type of cloud
        , condensed_mix_ratio &
!           Mixing ratios of condensed components
        , condensed_dim_char
!           Characteristic dimensions of condensed components
      REAL  (RealK) :: &
          condensed_param_list(lwdat%Dim%nd_cloud_parameter &
            , nd_cloud_component, lwdat%Dim%nd_band)
!           Coefficients in the parametrizations of condensed phases
!
!hmjb: CLOUD FIELD
      REAL (RealK), ALLOCATABLE, DIMENSION(:,:,:) :: clouds
!
!     AEROSOL FIELDS
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          aerosol_mix_ratio
!           Mixing ratios of aserosols
!
!     Fluxes and radiances calculated
      REAL(RealK), ALLOCATABLE, DIMENSION(:,:,:) :: &
          flux_direct &
!           Direct flux
        , flux_down &
!           Totol downward flux
        , flux_up &
!           Upward flux
        , flux_net &
!           Net flux
        , flux_direct_clear &
!           Clear-sky direct flux
        , flux_down_clear &
!           Clear-sky downward flux
        , flux_up_clear &
!           Clear-sky upward flux
        , flux_net_clear
!           Clear-sky Net flux

      REAL(RealK), DIMENSION(nd_j_profile, nd_viewing_level & 
           , nd_channel) :: photolysis
!           Calculated rates of photolysis
      REAL(RealK), DIMENSION(nd_radiance_profile, nd_viewing_level &
           , nd_direction, nd_channel) :: radiance
!           Radiances calculated


!     Dummy variables for use in calls to subroutines
!     (these are generally declared with the right shape
!     for bounds checking):
      INTEGER :: &
          i_dummy &
        , list_dummy(1)
      REAL  (RealK) :: &
          wb_dummy(lwdat%Dim%nd_band) &
        , ft_dummy(1, 1, nd_channel) &
        , tt_dummy(1, 1) &
        , rho_alb_dummy(1, nd_brdf_basis_fnc, 1, lwdat%Dim%nd_band)

      !---------------------------------------------------------------------
      ! AUX VARIABLES 
      !---------------------------------------------------------------------

      INTEGER      :: i  ! Loop variable
      INTEGER      :: j  ! Loop variable
      INTEGER      :: k  ! Loop variable

      INTEGER :: ntop 

      real(RealK) :: aux

      !---------------------------------------------------------------------
      ! INITIALIZATION
      !---------------------------------------------------------------------
      ntop = 0
      lw_toa_up_clr   = 0.0_r8
      lw_toa_up       = 0.0_r8
      lw_cool_clr     = 0.0_r8
      lw_cool         = 0.0_r8
      lw_sfc_net_clr  = 0.0_r8
      lw_sfc_net      = 0.0_r8
      lw_sfc_down_clr = 0.0_r8
      lw_sfc_down     = 0.0_r8

      ierr = i_normal

      !---------------------------------------------------------------------------
      ! Assign sizes
      !---------------------------------------------------------------------------
      n_profile = ncols
      n_layer = kmax + ntop

      nd_profile = n_profile
      nd_layer = n_layer
      nd_layer_clr = n_layer
      nd_2sg_profile = n_profile
      nd_flux_profile = n_profile

      !---------------------------------------------------------------------------
      ! ALLOCATE MEMORY
      !---------------------------------------------------------------------------

      Allocate( pres    (nd_profile, nd_layer))
      pres = 0.0_r8
      Allocate( temp    (nd_profile, nd_layer))
      temp = 0.0_r8
      Allocate( d_mass  (nd_profile, nd_layer))
      d_mass = 0.0_r8
      Allocate( t_ground(nd_profile))
      t_ground = 0.0_r8
      Allocate( t_level (nd_profile, 0:nd_layer))
      t_level = 0.0_r8
      Allocate( zen_0      (nd_profile))
      zen_0 = 0.0_r8
      Allocate( solar_irrad(nd_profile))
      solar_irrad = 0.0_r8
      Allocate( rho_alb(nd_profile, nd_brdf_basis_fnc, lwdat%Dim%nd_band))
      rho_alb = 0.0_r8

      Allocate( gas_mix_ratio(nd_profile, nd_layer, lwdat%Dim%nd_species))
      gas_mix_ratio = 0.0_r8
      Allocate( aerosol_mix_ratio(nd_profile, nd_layer, lwdat%Dim%nd_aerosol_species))
      aerosol_mix_ratio = 0.0_r8 

      Allocate( w_cloud            (nd_profile, id_ct:nd_layer))
      w_cloud = 0.0_r8
      Allocate( frac_cloud         (nd_profile, id_ct:nd_layer, nd_cloud_type))
      frac_cloud = 0.0_r8
      Allocate( condensed_mix_ratio(nd_profile, id_ct:nd_layer, nd_cloud_component))
      condensed_mix_ratio = 0.0_r8
      Allocate( condensed_dim_char (nd_profile, id_ct:nd_layer, nd_cloud_component))
      condensed_dim_char = 0.0_r8

      Allocate( clouds(nd_profile, id_ct:nd_layer, nd_cloud_type))
      clouds = 0.0_r8

      Allocate( flux_direct(nd_flux_profile, 0:nd_layer, nd_channel))
      flux_direct = 0.0_r8 
      Allocate( flux_down  (nd_flux_profile, 0:nd_layer, nd_channel))
      flux_down = 0.0_r8
      Allocate( flux_up    (nd_flux_profile, 0:nd_layer, nd_channel))
      flux_up = 0.0_r8
      Allocate( flux_net   (nd_flux_profile, 0:nd_layer, nd_channel))
      flux_net = 0.0_r8

      Allocate( flux_direct_clear(nd_2sg_profile,0:nd_layer,nd_channel))
      flux_direct_clear = 0.0_r8
      Allocate( flux_down_clear  (nd_2sg_profile,0:nd_layer,nd_channel))
      flux_down_clear = 0.0_r8
      Allocate( flux_up_clear    (nd_2sg_profile,0:nd_layer,nd_channel))
      flux_up_clear = 0.0_r8
      Allocate( flux_net_clear   (nd_2sg_profile,0:nd_layer,nd_channel))
      flux_net_clear = 0.0_r8


      !---------------------------------------------------------------------------
      ! Atmospheric Fields
      !---------------------------------------------------------------------------
      ! 
      DO i=1,nd_profile
         ! copy values to the end of the array
         DO k=ntop+1,nd_layer
            temp  (i,k) = Te (i,k-ntop)
            d_mass(i,k) = DP(i,k-ntop)*100.0_r8/grav_acc
            pres  (i,k) = Pmid (i,k-ntop)*100.0_r8
         ENDDO
         
         ! split the highest layer into ntop+1 layers
         ! i.e. add ntop layers on top, but keep total mass constant
         DO k=1,ntop+1
            temp  (i,k) = Te (i,1)
            d_mass(i,k) = DP(i,1)*100.0_r8/grav_acc/(ntop+1)
            pres  (i,k) = (2.0_r8*REAL(k,KIND=r8)-1.0_r8)*DP(i,1)*100.0_r8/REAL(ntop+1,kind=r8)/2.0_r8
         ENDDO

         t_ground(i) = Tg(i)

         ! interpolate layer temperatures to find values at levels
         DO k=ntop+1,nd_layer-1
            t_level(i,k) = (Te(i,k-ntop)+Te(i,k-ntop+1))/2.0_r8
         ENDDO
         t_level(i,nd_layer) = Tg(i)

         ! add ntop layers on top
         do k=0,ntop
            t_level(i,k) = Te(i,1)
         enddo
      ENDDO

      !---------------------------------------------------------------------------
      ! Solar fields
      !---------------------------------------------------------------------------
      ! Cosine of zenith angle and solar constant at each grid point
      zen_0 = -999.0_r8
      solar_irrad = -999.0_r8

      ! band weighting
      weight_band = 1.0_r8

      ! Method of treating scattering
      ! Note: MUST agree with i_solver, otherwise it won't work
      ! ERR:   IP_solver_triple_app_scat + IP_no_scatter_abs
      ! OK:   IP_solver_triple + IP_scatter_full
      !
      i_scatter_method = IP_scatter_full
      !i_scatter_method = IP_no_scatter_abs
      !i_scatter_method = IP_no_scatter_ext
      !hmjb See umdp_rad_main.pdf sec 2.10.3 e 4
      !hmjb Faster methods should only be used for short-time integrations

      ! Mapping of the lw spectrum (nine-bands) into one output band
      map_band_channel = 1

      ! Overlaps in each band
      i_gas_overlap = IP_overlap_k_eqv
      !i_gas_overlap = IP_overlap_random !hmjb: extremely slow

      !---------------------------------------------------------------------------
      ! Mixing ratios of gases considered 
      !---------------------------------------------------------------------------
      ! Note: This configuration relies on the order that the gases have been
      ! defined in the spectral file. So, if the spectral file is changed, this
      ! definition below (i.e. 1=h20, 2=co2, 3=o3, ...) must be changed 
      ! accordingly
      if (l_gas) then
         DO i=1,nd_profile
            DO k=ntop+1,nd_layer
               ! 1. Water vapour
               gas_mix_ratio(i,k,1) = Qe(i,k-ntop)/(1.0_r8-Qe(i,k-ntop))
               ! 2. co2
               gas_mix_ratio(i,k,2) = co2val*(CO2_mol_mass/dryair_mol_mass)*1.0e-6_r8
               ! 3. Ozone
               gas_mix_ratio(i,k,3) = O3(i,k-ntop)             
               ! 4. n2o
               !gas_mix_ratio(i,k,4) =     0.*(N2O_mol_mass/dryair_mol_mass)*1.0e-6
               ! 5. ch4
               !gas_mix_ratio(i,k,5) =     0.*(CH4_mol_mass/dryair_mol_mass)*1.0e-6
               ! 6 to 11. CFC's
               !gas_mix_ratio(:,:,6) =     0.*(CFC11_mol_mass/dryair_mol_mass)*1.0e-12
               !gas_mix_ratio(:,:,7) =     0.*(CFC12_mol_mass/dryair_mol_mass)*1.0e-12
               !gas_mix_ratio(:,:,8) =     0.*(CFC113_mol_mass/dryair_mol_mass)*1.0e-12
               !gas_mix_ratio(:,:,9) =     0.*(HCFC22_mol_mass/dryair_mol_mass)*1.0e-12
               !gas_mix_ratio(:,:,10)=     0.*(HFC125_mol_mass/dryair_mol_mass)*1.0e-12
               !gas_mix_ratio(:,:,11)=     0.*(HFC134a_mol_mass/dryair_mol_mass)*1.0e-12
            ENDDO

            ! repeat values in the extra layers
            do j=1,3 !hmjb
               gas_mix_ratio(i,1:ntop,j) = gas_mix_ratio(i,ntop+1,j)
            enddo
         ENDDO

         ! Value must be in parts-per-something-volume
      endif

      ! Doppler Broadening
      l_doppler = (/ &
           .true., .true., .true., .false., .false., &
           .false., .false., .false., .false., .false., .false. /)

      doppler_correction = (/ &
           2.35E+02_r8, 4.30E-03_r8, 1.21E+03_r8, 0.00E+00_r8, 0.00E+00_r8, &
           0.00E+00_r8, 0.00E+00_r8, 0.00E+00_r8, 0.00E+00_r8, 0.00E+00_r8, 0.00E+00_r8 /)

      !---------------------------------------------------------------------------
      ! Surface fields
      !---------------------------------------------------------------------------
      ! Emissivity = 1 - albedo
      ! In the future we should use an emissivity map instead of assuming Earth's
      ! surface to be a black body (emis=1.0)
      rho_alb=0.0_r8

      !---------------------------------------------------------------------------
      ! Aerosols
      !---------------------------------------------------------------------------
      !
      aerosol_mix_ratio = 0.0_r8
      ! consider only the first 5 aerosols in the list which correspond
      ! to the 5 climatological aerosols, and are the ones that we specify here
      if (l_aerosol) then
         do i=1,nd_profile
            if (imask(i).le.0_i8.or.imask(i).eq.13_i8) then
               aerosol_mix_ratio(i,ntop+1:ntop+nls ,1:5) = &
                    aerosol_clim_ocean(1:nls,1:5)/Pbot(i,kmax)/100.0_r8
               aerosol_mix_ratio(i,ntop+nls+1:nd_layer,1:5) = &
                    aerosol_clim_ocean(nls+1:kmax,1:5)
            else
               aerosol_mix_ratio(i,ntop+1:ntop+nls ,1:5) = &
                    aerosol_clim_land(1:nls,1:5)/Pbot(i,kmax)/100.0_r8
               aerosol_mix_ratio(i,ntop+nls+1:nd_layer,1:5) = &
                    aerosol_clim_land(nls+1:kmax,1:5)
            endif

            aerosol_mix_ratio(i,1:ntop,1) = aerosol_mix_ratio(i,ntop+1,1)
            aerosol_mix_ratio(i,1:ntop,2) = aerosol_mix_ratio(i,ntop+1,2)
            aerosol_mix_ratio(i,1:ntop,3) = aerosol_mix_ratio(i,ntop+1,3)
            aerosol_mix_ratio(i,1:ntop,4) = aerosol_mix_ratio(i,ntop+1,4)
            aerosol_mix_ratio(i,1:ntop,5) = aerosol_mix_ratio(i,ntop+1,5)
         enddo
      endif

      !---------------------------------------------------------------------------
      ! Clouds
      !---------------------------------------------------------------------------

      !---------------------------------------------------------------------------
      ! Cloud parameters and definitions
      type_condensed(1) = IP_clcmp_st_water  ! stratiform water droplets
      type_condensed(2) = IP_clcmp_st_ice    ! stratiform ice crystals
      type_condensed(3) = IP_clcmp_cnv_water ! convective water droplets
      type_condensed(4) = IP_clcmp_cnv_ice   ! convective ice crystals

      i_condensed_param(1) = lwdat%Drop%i_drop_parm(5)
      i_condensed_param(2) = lwdat%Ice%i_ice_parm(8)
      i_condensed_param(3) = lwdat%Drop%i_drop_parm(5)
      i_condensed_param(4) = lwdat%Ice%i_ice_parm(8)

      DO i=1,lwdat%Dim%nd_cloud_parameter
         DO k=1,lwdat%Dim%nd_band
            condensed_param_list(i,1,k)=lwdat%Drop%parm_list(i,k,5) ! st water  
            condensed_param_list(i,2,k)= lwdat%Ice%parm_list(i,k,8) ! st ice    
            condensed_param_list(i,3,k)=lwdat%Drop%parm_list(i,k,5) ! conv water
            condensed_param_list(i,4,k)= lwdat%Ice%parm_list(i,k,8) ! conv ice  
         ENDDO
      ENDDO

      !---------------------------------------------------------------------------
      ! Cloud Cover
      if (l_cloud) then
         DO i=1,nd_profile
            DO k=ntop+id_ct,nd_layer
               clouds(i,k,IP_cloud_type_sw) = cld(i,k-ntop)*&
                    (1.0_r8-fice(i,k-ntop)) ! st water
               clouds(i,k,IP_cloud_type_si) = cld(i,k-ntop)*&
                    fice(i,k-ntop)     ! st ice
               clouds(i,k,IP_cloud_type_cw) = clu(i,k-ntop)*&
                    (1.0_r8-fice(i,k-ntop)) ! conv water
               clouds(i,k,IP_cloud_type_ci) = clu(i,k-ntop)*&
                    fice(i,k-ntop)     ! conv ice
            enddo
            ! repeat values
            clouds(i,1:ntop,IP_cloud_type_sw) = clouds(i,ntop+1,IP_cloud_type_sw)
            clouds(i,1:ntop,IP_cloud_type_si) = clouds(i,ntop+1,IP_cloud_type_si)
            clouds(i,1:ntop,IP_cloud_type_cw) = clouds(i,ntop+1,IP_cloud_type_cw)
            clouds(i,1:ntop,IP_cloud_type_ci) = clouds(i,ntop+1,IP_cloud_type_ci)
         enddo

         DO i=1,nd_profile
            DO k=id_ct,nd_layer
               ! random overlap within each layer (mixing components)
               w_cloud(i,k) = 1.0_r8
               aux = 0.0_r8
               do j=1,n_condensed
                  w_cloud(i,k) = w_cloud(i,k)*(1.0_r8-clouds(i,k,j))
                  aux = aux + clouds(i,k,j)
               enddo
               w_cloud(i,k) = 1.0_r8 - w_cloud(i,k)
               
               ! not easy to calculate fractions without overlap, since 
               ! our clouds do overlap. for now, we take fractions of the sum
               IF (aux.GT.0.0_r8) frac_cloud(i,k,1:nd_cloud_type) = clouds(i,k,1:nd_cloud_type)/aux

            ENDDO
         ENDDO
      endif

      !---------------------------------------------------------------------------
      ! Mixing ratio of Water and Ice
      condensed_mix_ratio=0.0_r8
      condensed_dim_char=0.0_r8
      DO i=1,nd_profile
         DO k=ntop+id_ct,nd_layer
            condensed_mix_ratio(i,k,IP_cloud_type_sw)= &
                 lmixr(i,k-ntop)*(1.0_r8-fice(i,k-ntop))! st water  
            condensed_mix_ratio(i,k,IP_cloud_type_si)= &
                 lmixr(i,k-ntop)*fice(i,k-ntop)    ! st ice    
            condensed_mix_ratio(i,k,IP_cloud_type_cw)= &
                 lmixr(i,k-ntop)*(1.0_r8-fice(i,k-ntop))! conv water
            condensed_mix_ratio(i,k,IP_cloud_type_ci)= &
                 lmixr(i,k-ntop)*fice(i,k-ntop)    ! conv ice  

            condensed_dim_char(i,k,IP_cloud_type_sw)=rel(i,k-ntop)*1.e-6_r8 ! st water  
            condensed_dim_char(i,k,IP_cloud_type_si)=rei(i,k-ntop)*1.e-6_r8 ! st ice    
            condensed_dim_char(i,k,IP_cloud_type_cw)=rel(i,k-ntop)*1.e-6_r8 ! conv water
            condensed_dim_char(i,k,IP_cloud_type_ci)=rei(i,k-ntop)*1.e-6_r8 ! conv ice  
         ENDDO

         ! repeat values
         condensed_mix_ratio(i,1:ntop,IP_cloud_type_sw)= &
              condensed_mix_ratio(i,ntop+1,IP_cloud_type_sw)
         condensed_mix_ratio(i,1:ntop,IP_cloud_type_si)= &
              condensed_mix_ratio(i,ntop+1,IP_cloud_type_si)
         condensed_mix_ratio(i,1:ntop,IP_cloud_type_cw)= &
              condensed_mix_ratio(i,ntop+1,IP_cloud_type_cw)
         condensed_mix_ratio(i,1:ntop,IP_cloud_type_ci)= &
              condensed_mix_ratio(i,ntop+1,IP_cloud_type_ci)

         condensed_dim_char (i,1:ntop,IP_cloud_type_sw)= &
              condensed_dim_char (i,ntop+1,IP_cloud_type_sw)
         condensed_dim_char (i,1:ntop,IP_cloud_type_si)= &
              condensed_dim_char (i,ntop+1,IP_cloud_type_si)
         condensed_dim_char (i,1:ntop,IP_cloud_type_cw)= &
              condensed_dim_char (i,ntop+1,IP_cloud_type_cw)
         condensed_dim_char (i,1:ntop,IP_cloud_type_ci)= &
              condensed_dim_char (i,ntop+1,IP_cloud_type_ci)

      ENDDO

      !---------------------------------------------------------------------------
      ! CALCULATE RADIANCES OR IRRADIANCES
      !---------------------------------------------------------------------------

      CALL radiance_calc(ierr &
           !                       Logical Flags for Processes
           , l_rayleigh, l_aerosol, l_gas, l_continuum &
           , l_cloud, l_drop, l_ice &
           !                       Angular Integration
           , i_angular_integration, l_rescale, n_order_forward &
           , i_2stream &
           , n_order_gauss &
           , i_truncation, ls_global_trunc, ms_min, ms_max &
           , accuracy_adaptive, euler_factor &
           , l_henyey_greenstein_pf, ls_brdf_trunc &
           , i_sph_algorithm, n_order_phase_solar &
           , n_direction, direction &
           , n_viewing_level, viewing_level, i_sph_mode  &
           !                       Treatment of Scattering
           , i_scatter_method &
           !                       Options for treating clouds
           , l_global_cloud_top, n_global_cloud_top &
           !                       Options for Solver
           , i_solver &
           !                       Properties of diagnostics
           , map_band_channel &
           !                       General Spectral Properties
           , lwdat%Dim%nd_band, nmin, nmax, weight_band &
           !                       General Atmospheric Properties
           , nd_profile, nd_layer, pres, temp &
           , t_ground, t_level, d_mass &
           !                       Spectral Region
           , isolir &
           !                       Solar Fields
           , zen_0, solar_irrad, wb_dummy &
           , wb_dummy &
           !                       Infra-red Fields        
           , lwdat%Planck%n_deg_fit, lwdat%Planck%thermal_coeff, lwdat%Planck%t_ref_planck &
           , l_ir_source_quad &
           !                       Gaseous Absorption
           , i_gas_overlap, i_gas &
           , gas_mix_ratio, lwdat%Gas%n_band_absorb, lwdat%Gas%index_absorb &
           , lwdat%Gas%i_band_k, lwdat%Gas%w, lwdat%Gas%k, lwdat%Gas%i_scale_k &
           , lwdat%Gas%i_scale_fnc, lwdat%Gas%scale &
           , lwdat%Gas%p_ref, lwdat%Gas%t_ref &
           !                       Doppler Broadening
           , l_doppler, doppler_correction &
           !                       Surface Fields
           , n_brdf_basis_fnc, rho_alb, f_brdf &
           !                       Tiling options for heterogeneous surfaces
           , .false., i_dummy, i_dummy, list_dummy &
           , rho_alb_dummy, tt_dummy, tt_dummy &
           !                       Continuum Absorption
           , lwdat%Cont%n_band_continuum, lwdat%Cont%index_continuum, lwdat%Cont%index_water &
           , lwdat%Cont%k_cont, lwdat%Cont%i_scale_fnc_cont, lwdat%Cont%scale_cont &
           , lwdat%Cont%p_ref_cont, lwdat%Cont%t_ref_cont &
           !                       Properties of Aerosols
           , lwdat%Aerosol%n_aerosol, aerosol_mix_ratio &
           , lwdat%Aerosol%abs, lwdat%Aerosol%scat  &
           , lwdat%Aerosol%n_aerosol_phf_term, lwdat%Aerosol%phf_fnc &
           , lwdat%Aerosol%i_aerosol_parm, lwdat%Aerosol%nhumidity, lwdat%Aerosol%humidities &

           , n_opt_level_aerosol_prsc, n_phase_term_aerosol_prsc &
           , aerosol_pressure_prsc, aerosol_absorption_prsc &
           , aerosol_scattering_prsc, aerosol_phase_fnc_prsc &

           !                       Properties of Clouds
           , n_condensed, type_condensed &
           , i_cloud, i_cloud_representation, w_cloud &
           , n_cloud_type, frac_cloud &
           , condensed_mix_ratio, condensed_dim_char &
           , i_condensed_param, condensed_n_phf, condensed_param_list &
           , dp_corr_strat, dp_corr_conv &
           , n_opt_level_drop_prsc, n_phase_term_drop_prsc &
           , drop_pressure_prsc, drop_absorption_prsc &
           , drop_scattering_prsc, drop_phase_fnc_prsc &
           , n_opt_level_ice_prsc, n_phase_term_ice_prsc &
           , ice_pressure_prsc, ice_absorption_prsc &
           , ice_scattering_prsc, ice_phase_fnc_prsc &
           !                       Fluxes Calculated
           , flux_direct, flux_down, flux_up &
           , radiance, photolysis &
           !                       Options for Clear-sky Fluxes
           , l_clear, i_solver_clear &
           !                       Clear-sky Fluxes Calculated
           , flux_direct_clear, flux_down_clear, flux_up_clear &
           !                       Special Surface Fluxes
           , .false., wb_dummy, tt_dummy, tt_dummy, tt_dummy &
           !                       Tiled Surface Fluxes
           , ft_dummy, ft_dummy &
           !                       Dimensions of Arrays
           , nd_profile, nd_layer, nd_column, nd_layer, id_ct &
           , nd_2sg_profile, nd_flux_profile &
           , nd_radiance_profile, nd_j_profile &
           , nd_channel, lwdat%Dim%nd_band &
           , lwdat%Dim%nd_species, nd_esft_term, lwdat%Dim%nd_scale_variable &
           , lwdat%Dim%nd_continuum &
           , lwdat%Dim%nd_aerosol_species, lwdat%Dim%nd_humidity &
           , lwdat%Dim%nd_cloud_parameter &
           , lwdat%Dim%nd_thermal_coeff, nd_source_coeff &
           , nd_brdf_basis_fnc, nd_brdf_trunc &
           , nd_profile_aerosol_prsc, nd_profile_cloud_prsc &
           , nd_opt_level_aerosol_prsc, nd_opt_level_cloud_prsc &
           , lwdat%Dim%nd_phase_term, nd_max_order, nd_sph_coeff &
           , nd_direction, nd_viewing_level &
           , nd_region, nd_cloud_type, nd_cloud_component &
           , nd_overlap_coeff &
           , nd_point_tile, nd_tile)

      if (ierr/=0) stop

      ! Net flux at the interfaces
      DO i=1, nd_profile
         DO k=0, nd_layer
            DO j=1, nd_channel 
               flux_net(i,k,j)        = flux_down(i,k,j)       - flux_up(i,k,j)
               flux_net_clear(i,k,j)  = flux_down_clear(i,k,j) - flux_up_clear(i,k,j)
            ENDDO
         ENDDO
      ENDDO

      !---------------------------------------------------------------------------
      ! Convert available radiance_calc output to necessary swrad output
      !---------------------------------------------------------------------------
      ! Channel 1 = Infrared
      ! We keep the loop over the channel for completeness, but in the IR
      ! we map all bands to channel 1

      !---------------------------------------------------------------------------
      ! Surface and TOA come from the fluxes at the interfaces
      DO i=1,nd_profile
         DO j=1,nd_channel
            lw_toa_up_clr   (i) = lw_toa_up_clr   (i) + flux_up_clear(i,0,j)
            lw_toa_up       (i) = lw_toa_up       (i) + flux_up      (i,0,j)
            ! Model defines NetLong as positive, i.e., UP-DOWN (hmjb 18feb08)
            lw_sfc_net_clr  (i) = lw_sfc_net_clr  (i) - flux_net_clear (i,nd_layer,j)
            lw_sfc_net      (i) = lw_sfc_net      (i) - flux_net       (i,nd_layer,j)
            lw_sfc_down_clr (i) = lw_sfc_down_clr (i) + flux_down_clear(i,nd_layer,j)
            lw_sfc_down     (i) = lw_sfc_down     (i) + flux_down      (i,nd_layer,j)
         ENDDO
      ENDDO

      !-----------------------------------------------------------------------
      ! CALCULATION OF LW Cooling Rarte. The model expects K/s.
      !-----------------------------------------------------------------------

      ! We are loosing the heating in the extra layer at the top of the atmosphere. 
      ! This used to be done in old radiation codes, for avoiding a very large 
      ! value at the top that would make the model unstable. Need to check if 
      ! that's necessary with kmax>=28
      DO i=1,nd_profile
         DO k=1,kmax
            DO j=1,nd_channel
               lw_cool(i,k) = lw_cool(i,k)                                          &
                    + (flux_net(i,ntop+k-1,j)-flux_net(i,ntop+k,j))/                &
                    (d_mass(i,ntop+k)*cp_air_dry)

               lw_cool_clr(i,k) = lw_cool_clr(i,k)                                  &
                    + (flux_net_clear(i,ntop+k-1,j)-flux_net_clear(i,ntop+k,j))/    &
                    (d_mass(i,ntop+k)*cp_air_dry)
            ENDDO
         ENDDO
      ENDDO

      !---------------------------------------------------------------------------
      ! DEALLOCATE MEMORY
      !---------------------------------------------------------------------------

      Deallocate( pres )
      Deallocate( temp )
      Deallocate( d_mass )
      Deallocate( t_ground )
      Deallocate( t_level )
      Deallocate( zen_0 )
      Deallocate( solar_irrad )
      Deallocate( rho_alb )

      Deallocate( gas_mix_ratio )
      Deallocate( aerosol_mix_ratio )

      Deallocate( w_cloud )
      Deallocate( frac_cloud )
      Deallocate( condensed_mix_ratio )
      Deallocate( condensed_dim_char )
      Deallocate( clouds )

      Deallocate( flux_direct )
      Deallocate( flux_down )
      Deallocate( flux_up )
      Deallocate( flux_net )

      Deallocate( flux_direct_clear )
      Deallocate( flux_down_clear )
      Deallocate( flux_up_clear )
      Deallocate( flux_net_clear )

      RETURN
  END SUBROUTINE ukmo_lwintf

END MODULE Rad_UKMO
