! ! $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 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