module rad_utilities_mod ! ! ! fil ! ! ! smf ! ! ! ! Code to define the derived data types and provide table search routines. ! ! ! This code is used in the radiation code package as a helper module. ! It defines many derived data types used in radiation calculation. ! This code also provides table search routines and simple arithmatic ! routines. ! ! use mpp_mod, only : input_nml_file use fms_mod, only : open_namelist_file, fms_init, & mpp_pe, mpp_root_pe, stdlog, & file_exist, write_version_number, & check_nml_error, error_mesg, & FATAL, close_file, lowercase use field_manager_mod, only : parse use time_manager_mod, only : time_type !-------------------------------------------------------------------- implicit none private !--------------------------------------------------------------------- ! rad_utilities_mod contains radiation table search routines, ! some band averaging routines, and the derived-type variables ! used in the radiation package. !--------------------------------------------------------------------- !--------------------------------------------------------------------- !----------- ****** VERSION NUMBER ******* --------------------------- character(len=128) :: version = '$Id: rad_utilities.F90,v 20.0 2013/12/13 23:20:23 fms Exp $' character(len=128) :: tagname = '$Name: tikal $' !--------------------------------------------------------------------- !------- interfaces -------- public & rad_utilities_init, check_derived_types, & locate_in_table, & looktab, table_alloc, & thickavg, thinavg, & rad_utilities_end, & get_radiative_param, assignment(=) interface looktab module procedure looktab_type1, looktab_type2, looktab_type3 end interface interface table_alloc module procedure table1_alloc, table2_alloc, table3_alloc end interface interface thickavg module procedure thickavg_3d module procedure thickavg_0d module procedure thickavg_1band module procedure thickavg_isccp end interface interface assignment(=) module procedure lw_output_type_eq module procedure sw_output_type_eq module procedure aerosol_props_type_eq end interface !------------------------------------------------------------------ public aerosol_type ! aerosol ! aerosol_names ! family_members type aerosol_type real, dimension(:,:,:,:), pointer :: aerosol=>NULL() logical, dimension(:,:), pointer :: family_members=>NULL() character(len=64), dimension(:), pointer :: aerosol_names=>NULL() end type aerosol_type !------------------------------------------------------------------ public aerosol_diagnostics_type ! extopdep ! absopdep ! extopdep_vlcno ! absopdep_vlcno ! lw_extopdep_vlcno ! lw_absopdep_vlcno ! sw_heating_vlcno type aerosol_diagnostics_type ! real, dimension(:,:,:), pointer :: sw_heating_vlcno=>NULL() real, dimension(:,:,:,:), pointer :: sw_heating_vlcno=>NULL() real, dimension(:,:,:,:,:), pointer :: extopdep=>NULL(), & absopdep=>NULL() real, dimension(:,:,:,:,:), pointer :: asymdep=>NULL() real, dimension(:,:,:,:), pointer :: extopdep_vlcno=>NULL(), & absopdep_vlcno=>NULL(), & lw_extopdep_vlcno=>NULL(), & lw_absopdep_vlcno=>NULL() end type aerosol_diagnostics_type !------------------------------------------------------------------ public aerosol_properties_type ! aerextband ! aerssalbband ! aerasymmband ! aerextbandlw ! aerssalbbandlw ! sulfate_index ! optical_index type aerosol_properties_type integer, dimension(:,:,:), pointer :: ivol=>NULL() real, dimension(:,:), pointer :: aerextband=>NULL(), & aerssalbband=>NULL(), & aerasymmband=>NULL(), & aerextbandlw=>NULL(), & aerssalbbandlw=>NULL(), & aerextbandlw_cn=>NULL(), & aerssalbbandlw_cn=>NULL() real, dimension(:,:,:,:), pointer :: sw_ext=>NULL(), & sw_ssa=>NULL(), & sw_asy=>NULL(), & lw_ext=>NULL(), & lw_ssa=>NULL(), & lw_asy=>NULL() !yim integer, dimension(:,:), pointer :: sulfate_index=>NULL() integer, dimension(:), pointer :: optical_index=>NULL() integer, dimension(:), pointer :: omphilic_index=>NULL() integer, dimension(:), pointer :: bcphilic_index=>NULL() integer, dimension(:), pointer :: seasalt1_index=>NULL() integer, dimension(:), pointer :: seasalt2_index=>NULL() integer, dimension(:), pointer :: seasalt3_index=>NULL() integer, dimension(:), pointer :: seasalt4_index=>NULL() integer, dimension(:), pointer :: seasalt5_index=>NULL() integer :: sulfate_flag integer :: omphilic_flag integer :: bcphilic_flag integer :: seasalt1_flag integer :: seasalt2_flag integer :: seasalt3_flag integer :: seasalt4_flag integer :: seasalt5_flag !yim integer :: bc_flag end type aerosol_properties_type !------------------------------------------------------------------ public astronomy_type ! solar ! cosz ! fracday ! rrsun type astronomy_type real, dimension(:,:), pointer :: solar=>NULL(), & cosz=>NULL(), & fracday=>NULL() real, dimension(:,:,:), pointer :: solar_p=>NULL(), & cosz_p=>NULL(), & fracday_p=>NULL() real :: rrsun end type astronomy_type !-------------------------------------------------------------------- public astronomy_inp_type ! zenith_angle specified zenith angles [ degrees ] ! fracday specified daylight fraction [ fraction ] ! rrsun specified earth-sun distance, normalized by mean ! distance type astronomy_inp_type real, dimension(:,:), pointer :: zenith_angle=>NULL() real, dimension(:,:), pointer :: fracday=>NULL() real :: rrsun end type astronomy_inp_type !-------------------------------------------------------------------- public atmos_input_type ! press ! temp ! rh2o ! zfull ! pflux ! tflux ! deltaz ! phalf ! rel_hum ! cloudtemp ! clouddeltaz ! cloudvapor ! aerosoltemp ! aerosolvapor ! aerosolpress ! aerosolrelhum ! tracer_co2 ! g_rrvco2 ! tsfc ! psfc type atmos_input_type real, dimension(:,:,:), pointer :: press=>NULL(), & temp=>NULL(), & rh2o=>NULL(), & zfull=>NULL(), & pflux=>NULL(), & tflux=>NULL(), & deltaz=>NULL(), & phalf=>NULL(), & rel_hum=>NULL(), & cloudtemp=>NULL(), & clouddeltaz=>NULL(), & cloudvapor=>NULL(), & aerosoltemp=>NULL(), & aerosolvapor=>NULL(), & aerosolpress=>NULL(), & aerosolrelhum=>NULL(), & tracer_co2 => NULL() real, dimension(:,:), pointer :: tsfc=>NULL(), & psfc=>NULL() real :: g_rrvco2 end type atmos_input_type !------------------------------------------------------------------- public cldrad_properties_type ! cldext ! cldasymm ! cldsct ! emmxolw ! emrndlw ! abscoeff ! cldemiss ! cirabsw ! cirrfsw ! cvisrfsw type cldrad_properties_type real, dimension(:,:,:,:,:), pointer :: cldext=>NULL(), & cldasymm=>NULL(), & cldsct=>NULL() real, dimension(:,:,:,:,:), pointer :: & emmxolw=>NULL(), & emrndlw=>NULL(), & abscoeff=>NULL(), & cldemiss=>NULL() real, dimension(:,:,:), pointer :: cirabsw=>NULL(), & cirrfsw=>NULL(), & cvisrfsw=>NULL() end type cldrad_properties_type !------------------------------------------------------------------ public cld_space_properties_type ! camtswkc ! cirabswkc ! cirrfswkc ! cvisrfswkc ! ktopswkc ! kbtmswkc type cld_space_properties_type real, dimension(:,:,:), pointer :: camtswkc=>NULL() real, dimension(:,:,:), pointer :: cirabswkc=>NULL(), & cirrfswkc=>NULL(), & cvisrfswkc=>NULL() integer, dimension(:,:,:), pointer :: ktopswkc=>NULL(), & kbtmswkc=>NULL() end type cld_space_properties_type !------------------------------------------------------------------ public cld_specification_type ! tau ! lwp ! iwp ! reff_liq ! reff_ice ! liq_frac ! cloud_water ! cloud_ice ! cloud_area ! cloud_droplet ! reff_liq_micro ! reff_ice_micro ! camtsw ! cmxolw ! crndlw ! cld_thickness ! ncldsw ! nmxolw ! nrndlw ! hi_cloud ! mid_cloud ! low_cloud ! ice_cloud type cld_specification_type real, dimension(:,:,:,:), pointer :: tau=>NULL(), & camtsw_band=>NULL(), & crndlw_band=>NULL(), & lwp_lw_band=>NULL(), & iwp_lw_band=>NULL(), & lwp_sw_band=>NULL(), & iwp_sw_band=>NULL(), & reff_liq_lw_band=>NULL(), & reff_ice_lw_band=>NULL(), & reff_liq_sw_band=>NULL(), & reff_ice_sw_band=>NULL() real, dimension(:,:,:), pointer :: lwp=>NULL(), & iwp=>NULL(), & reff_liq=>NULL(), & reff_ice=>NULL(), & reff_liq_lim=>NULL(), & reff_ice_lim=>NULL(), & liq_frac=>NULL(), & cloud_water=>NULL(), & cloud_ice=>NULL(), & cloud_area=>NULL(), & cloud_droplet=>NULL(), & cloud_ice_num=>NULL(), & ! snow, rain rain =>NULL(), & snow =>NULL(), & rain_size =>NULL(), & snow_size =>NULL(), & reff_liq_micro=>NULL(), & reff_ice_micro=>NULL(),& camtsw=>NULL(), & cmxolw=>NULL(), & crndlw=>NULL() integer, dimension(:,:,:), pointer :: cld_thickness=>NULL() integer, dimension(:,:,:,:), pointer :: stoch_cloud_type=>NULL() integer, dimension(:,:,:,:), pointer :: cld_thickness_lw_band=>NULL() integer, dimension(:,:,:,:), pointer :: cld_thickness_sw_band=>NULL() integer, dimension(:,:), pointer :: ncldsw=>NULL(), & nmxolw=>NULL(),& nrndlw=>NULL() integer, dimension(:,:,:), pointer :: ncldsw_band=>NULL(), & nrndlw_band=>NULL() logical, dimension(:,:,:), pointer :: hi_cloud=>NULL(), & mid_cloud=>NULL(), & low_cloud=>NULL(), & ice_cloud=>NULL() end type cld_specification_type !------------------------------------------------------------------ public cloudrad_control_type type cloudrad_control_type logical :: do_pred_cld_microphys logical :: do_presc_cld_microphys logical :: do_bulk_microphys logical :: do_sw_micro logical :: do_lw_micro logical :: do_rh_clouds logical :: do_strat_clouds logical :: do_zonal_clouds logical :: do_mgroup_prescribed logical :: do_obs_clouds logical :: do_no_clouds logical :: do_diag_clouds logical :: do_specified_clouds logical :: do_donner_deep_clouds logical :: do_uw_clouds logical :: do_zetac_clouds logical :: do_random_overlap logical :: do_max_random_overlap logical :: do_stochastic_clouds logical :: use_temp_for_seed logical :: do_specified_strat_clouds logical :: do_ica_calcs logical :: do_liq_num logical :: do_ice_num logical :: using_fu2007 integer :: nlwcldb ! number of frequency bands ! for which lw cloud emissiv- ! ities are defined. integer :: cloud_data_points integer :: ich integer :: icm integer :: ict integer :: icb logical :: do_pred_cld_microphys_iz logical :: do_presc_cld_microphys_iz logical :: do_bulk_microphys_iz logical :: do_sw_micro_iz logical :: do_lw_micro_iz logical :: do_rh_clouds_iz logical :: do_strat_clouds_iz logical :: do_zonal_clouds_iz logical :: do_mgroup_prescribed_iz logical :: do_obs_clouds_iz logical :: do_no_clouds_iz logical :: do_diag_clouds_iz logical :: do_specified_clouds_iz logical :: do_donner_deep_clouds_iz logical :: do_uw_clouds_iz logical :: do_zetac_clouds_iz logical :: do_random_overlap_iz logical :: do_max_random_overlap_iz logical :: do_stochastic_clouds_iz logical :: use_temp_for_seed_iz logical :: do_specified_strat_clouds_iz logical :: do_ica_calcs_iz logical :: do_liq_num_iz logical :: do_ice_num_iz logical :: using_fu2007_iz end type cloudrad_control_type !------------------------------------------------------------------ public fsrad_output_type ! tdtsw ! tdtlw ! tdtsw_clr ! tdtlw_clr ! swdns ! swups ! lwdns ! lwups ! swin ! swout ! olr ! swdns_clr ! swups_clr ! lwdns_clr ! lwups_clr` ! swin_clr ! swout_clr ! olr_clr ! npass type fsrad_output_type real, dimension(:,:,:), pointer :: tdtsw=>NULL(), & tdtlw=>NULL(), & tdtsw_clr=>NULL(), & tdtlw_clr=>NULL() real, dimension(:,:), pointer :: swdns=>NULL(), & swups=>NULL(), & lwups=>NULL(), & lwdns=>NULL(), & swin=>NULL(), & swout=>NULL(), & olr=>NULL(), & swdns_clr=>NULL(), & swups_clr=>NULL(), & lwups_clr=>NULL(),& lwdns_clr=>NULL(), & swin_clr=>NULL(), & swout_clr=>NULL(), & olr_clr=>NULL() integer :: npass end type fsrad_output_type !------------------------------------------------------------------- public gas_tf_type ! tdav ! tlsqu ! tmpdiff ! tstdav ! co2nbl ! n2o9c ! tn2o17 ! co2spnb ! a1 ! a2 type gas_tf_type real, dimension(:,:,:), pointer :: tdav=>NULL(), & tlsqu=>NULL(), & tmpdiff=>NULL(), & tstdav=>NULL(), & co2nbl=>NULL(), & n2o9c=>NULL(), & tn2o17=>NULL() real, dimension(:,:,:,:), pointer :: co2spnb=>NULL() real, dimension(:,:), pointer :: a1=>NULL(), & a2=>NULL() end type gas_tf_type !------------------------------------------------------------------ public longwave_control_type type longwave_control_type character(len=16) :: lw_form character(len=16) :: continuum_form character(len=16) :: linecatalog_form logical :: do_cfc logical :: do_lwaerosol logical :: do_ch4 logical :: do_n2o logical :: do_ch4lbltmpint logical :: do_n2olbltmpint logical :: do_co2 logical :: do_lwcldemiss logical :: do_h2o logical :: do_o3 logical :: do_cfc_iz logical :: do_lwaerosol_iz logical :: do_ch4_iz logical :: do_n2o_iz logical :: do_ch4lbltmpint_iz logical :: do_n2olbltmpint_iz logical :: do_co2_iz logical :: do_lwcldemiss_iz logical :: do_h2o_iz logical :: do_o3_iz end type longwave_control_type !--------------------------------------------------------------------- public longwave_parameter_type type longwave_parameter_type integer :: offset integer :: NBTRG integer :: NBTRGE integer :: NBLY integer :: n_lwaerosol_bands real :: lw_band_resolution logical :: offset_iz logical :: NBTRG_iz logical :: NBTRGE_iz logical :: NBLY_iz logical :: n_lwaerosol_bands_iz logical :: lw_band_resolution_iz end type longwave_parameter_type !-------------------------------------------------------------------- public longwave_tables1_type ! vae ! td ! md ! cd type longwave_tables1_type real, dimension(:,:), pointer :: vae=>NULL(), & td=>NULL(), & md=>NULL(), & cd=>NULL() end type longwave_tables1_type !-------------------------------------------------------------------- public longwave_tables2_type ! vae ! td ! md ! cd type longwave_tables2_type real, dimension(:,:,:), pointer :: vae=>NULL(), & td=>NULL(), & md=>NULL(), & cd=>NULL() end type longwave_tables2_type !--------------------------------------------------------------------- public longwave_tables3_type ! vae ! td type longwave_tables3_type real, dimension(:,:), pointer :: vae=>NULL(), & td=>NULL() end type longwave_tables3_type !--------------------------------------------------------------------- public lw_clouds_type ! taucld_rndlw ! taucld_mxolw ! taunbl_mxolw type lw_clouds_type real, dimension(:,:,:,:), pointer :: taucld_rndlw=>NULL(), & taucld_mxolw=>NULL(), & taunbl_mxolw=>NULL() end type lw_clouds_type !------------------------------------------------------------------ public lw_diagnostics_type ! flx1e1 ! gxcts ! flx1e1f ! excts ! fctsg ! fluxn ! fluxncf ! exctsn ! cts_out ! cts_outcf type lw_diagnostics_type real, dimension(:,:), pointer :: flx1e1=>NULL(), & gxcts=>NULL() real, dimension(:,:,:), pointer :: flx1e1f=>NULL(), & excts=>NULL(),& fctsg=>NULL() real, dimension(:,:,:,:), pointer :: fluxn=>NULL(), & fluxncf=>NULL(), & exctsn=>NULL(), & cts_out=>NULL(), & cts_outcf=>NULL() end type lw_diagnostics_type !------------------------------------------------------------------- public lw_output_type ! heatra ! flxnet ! heatracf ! flxnetcf ! netlw_special ! netlw_special_clr type lw_output_type real, dimension(:,:,:), pointer :: heatra=>NULL(), & flxnet=>NULL(), & heatracf=>NULL(), & flxnetcf=>NULL() real, dimension(:,:,:), pointer :: netlw_special=>NULL(), & netlw_special_clr=>NULL(), & bdy_flx=>NULL(), & bdy_flx_clr=>NULL() end type lw_output_type !------------------------------------------------------------------ public lw_table_type ! bdlocm ! bdhicm ! bandlo ! bandhi ! iband type lw_table_type real, dimension(:), pointer :: bdlocm=>NULL(), & bdhicm=>NULL(), & bandlo=>NULL(), & bandhi=>NULL() integer, dimension(:), pointer :: iband=>NULL() end type lw_table_type !------------------------------------------------------------------ public microphysics_type ! conc_ice ! conc_drop ! size_ice ! size_drop ! size_snow ! conc_snow ! size_rain ! conc_rain ! cldamt ! stoch_conc_ice ! stoch_conc_drop ! stoch_size_ice ! stoch_size_drop ! stoch_cldamt ! stoch_cloud_type ! lw_stoch_conc_ice ! lw_stoch_conc_drop ! lw_stoch_size_ice ! lw_stoch_size_drop ! lw_stoch_cldamt ! sw_stoch_conc_ice ! sw_stoch_conc_drop ! sw_stoch_size_ice ! sw_stoch_size_drop ! sw_stoch_cldamt type microphysics_type real, dimension(:,:,:), pointer :: conc_ice=>NULL(), & conc_drop=>NULL(), & size_ice=>NULL(), & size_drop=>NULL(), & size_snow=>NULL(), & conc_snow=>NULL(), & size_rain=>NULL(), & conc_rain=>NULL(), & cldamt=>NULL(), & droplet_number=>NULL(), & ice_number=>NULL() real, dimension(:,:,:,:), pointer :: stoch_conc_ice=>NULL(), & stoch_conc_drop=>NULL(), & stoch_size_ice=>NULL(), & stoch_size_drop=>NULL(), & stoch_cldamt=>NULL(), & stoch_droplet_number=>NULL(), & stoch_ice_number=>NULL() integer, dimension(:,:,:,:), pointer :: stoch_cloud_type=>NULL() ! ! In practice, we allocate a single set of columns for the stochastic ! clouds, then point to sections of the larger array with the ! lw_ and sw_type. ! I.e. lw_stoch_conc_ice => stoch_conc_ice(:, :, :, 1:numLwBands) ! real, dimension(:,:,:,:), pointer :: lw_stoch_conc_ice=>NULL(), & lw_stoch_conc_drop=>NULL(), & lw_stoch_size_ice=>NULL(), & lw_stoch_size_drop=>NULL(), & lw_stoch_cldamt=>NULL(), & lw_stoch_droplet_number=>NULL(), & lw_stoch_ice_number=>NULL(), & sw_stoch_conc_ice=>NULL(), & sw_stoch_conc_drop=>NULL(), & sw_stoch_size_ice=>NULL(), & sw_stoch_size_drop=>NULL(), & sw_stoch_cldamt=>NULL(), & sw_stoch_droplet_number=>NULL(), & sw_stoch_ice_number=>NULL() end type microphysics_type !------------------------------------------------------------------- public microrad_properties_type ! cldext ! cldsct ! cldasymm ! abscoeff type microrad_properties_type real, dimension(:,:,:,:), pointer :: cldext=>NULL(), & cldsct=>NULL(), & cldasymm=>NULL(), & abscoeff=>NULL() end type microrad_properties_type !-------------------------------------------------------------------- public optical_path_type ! empl1f ! vrpfh2o ! xch2obd ! tphfh2o ! avephif ! totaerooptdep ! empl1 ! empl2 ! var1 ! var2 ! emx1f ! emx2f ! totvo2 ! avephi ! totch2obdwd ! xch2obdwd ! totphi ! cntval ! toto3 ! tphio3 ! var3 ! var4 ! wk ! rh2os ! rfrgn ! tfac ! totaerooptdep15 ! totf11 ! totf12 ! totf113 ! totf22 ! emx1 ! emx2 ! csfah2o ! aerooptdep_KE_15 type optical_path_type real, dimension (:,:,:,:), pointer :: empl1f=>NULL(), & empl2f=>NULL(), & vrpfh2o=>NULL(), & xch2obd=>NULL(), & tphfh2o=>NULL(), & avephif=>NULL(), & totaerooptdep=>NULL() real, dimension (:,:,:), pointer :: empl1=>NULL(), & empl2=>NULL(), & var1=>NULL(), & var2=>NULL(), & emx1f=>NULL(), & emx2f=>NULL(), & totvo2=>NULL(), & avephi=>NULL(),& totch2obdwd=>NULL(), & xch2obdwd=>NULL(), & totphi=>NULL(), & cntval=>NULL(), & toto3=>NULL(), & tphio3=>NULL(), & var3=>NULL(), & var4=>NULL(), & wk=>NULL(), & rh2os=>NULL(), & rfrgn=>NULL(), & tfac=>NULL(), & totaerooptdep_15=>NULL(), & totf11=>NULL(), & totf12=>NULL(), & totf113=>NULL(), & totf22=>NULL() real, dimension (:,:), pointer :: emx1=>NULL(), & emx2=>NULL(), & csfah2o=>NULL(), & aerooptdep_KE_15=>NULL() end type optical_path_type !------------------------------------------------------------------ public radiation_control_type type radiation_control_type logical :: do_totcld_forcing logical :: do_aerosol integer :: rad_time_step integer :: lw_rad_time_step integer :: sw_rad_time_step logical :: do_sw_rad logical :: do_lw_rad logical :: hires_coszen integer :: nzens real :: co2_tf_calc_intrvl logical :: use_current_co2_for_tf logical :: calc_co2_tfs_on_first_step logical :: calc_co2_tfs_monthly real :: co2_tf_time_displacement real :: ch4_tf_calc_intrvl logical :: use_current_ch4_for_tf logical :: calc_ch4_tfs_on_first_step logical :: calc_ch4_tfs_monthly real :: ch4_tf_time_displacement real :: n2o_tf_calc_intrvl logical :: use_current_n2o_for_tf logical :: calc_n2o_tfs_on_first_step logical :: calc_n2o_tfs_monthly real :: n2o_tf_time_displacement integer :: mx_spec_levs logical :: time_varying_solar_constant logical :: volcanic_sw_aerosols logical :: volcanic_lw_aerosols logical :: using_solar_timeseries_data logical :: do_lwaerosol_forcing logical :: do_swaerosol_forcing integer :: indx_swaf integer :: indx_lwaf logical :: using_im_bcsul logical :: do_totcld_forcing_iz logical :: do_aerosol_iz logical :: rad_time_step_iz logical :: lw_rad_time_step_iz logical :: sw_rad_time_step_iz logical :: do_sw_rad_iz logical :: do_lw_rad_iz logical :: hires_coszen_iz logical :: nzens_iz logical :: co2_tf_calc_intrvl_iz logical :: use_current_co2_for_tf_iz logical :: calc_co2_tfs_on_first_step_iz logical :: calc_co2_tfs_monthly_iz logical :: ch4_tf_calc_intrvl_iz logical :: use_current_ch4_for_tf_iz logical :: calc_ch4_tfs_on_first_step_iz logical :: calc_ch4_tfs_monthly_iz logical :: n2o_tf_calc_intrvl_iz logical :: use_current_n2o_for_tf_iz logical :: calc_n2o_tfs_on_first_step_iz logical :: calc_n2o_tfs_monthly_iz logical :: co2_tf_time_displacement_iz logical :: ch4_tf_time_displacement_iz logical :: n2o_tf_time_displacement_iz logical :: mx_spec_levs_iz logical :: time_varying_solar_constant_iz logical :: volcanic_sw_aerosols_iz logical :: volcanic_lw_aerosols_iz logical :: using_solar_timeseries_data_iz logical :: do_lwaerosol_forcing_iz logical :: do_swaerosol_forcing_iz logical :: indx_swaf_iz logical :: indx_lwaf_iz logical :: using_im_bcsul_iz end type radiation_control_type !------------------------------------------------------------------ public radiative_gases_type ! qo3 ! rrvch4 ! rrvn2o ! rrvco2 ! rrvf11 ! rrvf12 ! rrvf113 ! rrvf22 ! rf11air ! rf12air ! rf113air ! rf22air ! time_varying_co2 ! time_varying_f11 ! time_varying_f12 ! time_varying_f113 ! time_varying_f22 ! time_varying_ch4 ! time_varying_n2o type radiative_gases_type real, dimension(:,:,:), pointer :: qo3=>NULL() real :: rrvch4, rrvn2o, rrvco2, & rrvf11, rrvf12, rrvf113, & rrvf22, rf11air, rf12air, & rf113air, rf22air, & co2_for_last_tf_calc, & co2_tf_offset, & co2_for_next_tf_calc, & ch4_for_last_tf_calc, & ch4_tf_offset, & ch4_for_next_tf_calc, & n2o_for_last_tf_calc, & n2o_tf_offset, & n2o_for_next_tf_calc logical :: time_varying_co2, & time_varying_f11, & time_varying_f12, & time_varying_f113, & time_varying_f22, & time_varying_ch4, & time_varying_n2o, & use_model_supplied_co2 type(time_type) :: Co2_time, Ch4_time, N2o_time end type radiative_gases_type !------------------------------------------------------------------ public rad_output_type ! tdt_rad ! tdt_rad_clr ! tdtsw ! tdtsw_clr ! tdtlw ! flux_sw_surf ! flux_lw_surf ! coszen_angle type rad_output_type real, dimension(:,:,:,:), pointer :: tdt_rad=>NULL(), & ufsw=>NULL(), & dfsw=>NULL(), & tdtsw=>NULL() real, dimension(:,:,:,:), pointer :: tdt_rad_clr=>NULL(), & ufsw_clr=>NULL(), & dfsw_clr=>NULL(), & tdtsw_clr=>NULL() real, dimension(:,:,:), pointer :: tdtlw=>NULL() real, dimension(:,:,:), pointer :: flxnet=>NULL() real, dimension(:,:,:), pointer :: flxnetcf=>NULL() real, dimension(:,:,:), pointer :: tdtlw_clr=>NULL() real, dimension(:,:,:), pointer :: flux_sw_surf=>NULL(), & flux_sw_surf_refl_dir=>NULL(), & flux_sw_surf_dir=>NULL(), & flux_sw_surf_dif=>NULL(), & flux_sw_down_vis_dir=>NULL(), & flux_sw_down_vis_dif=>NULL(), & flux_sw_down_total_dir=>NULL(), & flux_sw_down_total_dif=>NULL(), & flux_sw_vis=>NULL(), & flux_sw_vis_dir=>NULL(), & flux_sw_refl_vis_dir=>NULL(), & flux_sw_vis_dif=>NULL() real, dimension(:,:,:), pointer :: flux_sw_down_vis_clr=>NULL(), & flux_sw_down_total_dir_clr=>NULL(), & flux_sw_down_total_dif_clr=>NULL() real, dimension(:,:), pointer :: flux_lw_surf=>NULL(), & coszen_angle=>NULL() end type rad_output_type !------------------------------------------------------------------- public shortwave_control_type type shortwave_control_type logical :: do_lhsw logical :: do_esfsw logical :: do_swaerosol logical :: do_diurnal logical :: do_annual logical :: do_daily_mean logical :: do_cmip_diagnostics real :: solar_constant logical :: do_lhsw_iz logical :: do_esfsw_iz logical :: do_swaerosol_iz logical :: do_diurnal_iz logical :: do_annual_iz logical :: do_daily_mean_iz logical :: do_cmip_diagnostics_iz end type shortwave_control_type !--------------------------------------------------------------------- public solar_spectrum_type ! solarfluxtoa highly-resolved solar flux at toa in ! Sw_control%tot_wvnums ! bands [ ] ! solflxband_lean a time series of toa solar flux in each ! parameterization band ! solflxband_lean_ann_1882 1882 average toa solar flux in each ! parameterization band ! solflxband_lean_ann_2000 2000 average toa solar flux in each ! parameterization band ! solflxband toa solar flux in each parameterization band ! [ ] ! endwvnbands highest wave number in each of the solar ! spectral parameterization bands [ cm (-1) ] ! tot_wvnums ! nbands ! nfrqpts ! nstreams ! nh2obands ! visible_band_indx ! one_micron_indx ! eight70_band_indx ! visible_band_indx_iz ! one_micron_indx_iz ! eight70_band_indx_iz type solar_spectrum_type real, dimension(:), pointer :: solarfluxtoa=>null() real, dimension(:), pointer :: solflxband=>NULL() real, dimension(:), pointer :: solflxbandref=>NULL() real, dimension(:), pointer :: solflxband_lean_ann_1882=>NULL() real, dimension(:), pointer :: solflxband_lean_ann_2000=>NULL() real, dimension(:,:,:),pointer :: solflxband_lean=>NULL() integer, dimension(:), pointer :: endwvnbands=>NULL() integer :: tot_wvnums integer :: nbands integer :: nfrqpts integer :: nstreams integer :: nh2obands integer :: visible_band_indx, one_micron_indx integer :: eight70_band_indx logical :: visible_band_indx_iz, one_micron_indx_iz logical :: eight70_band_indx_iz integer :: w340_band_indx, w380_band_indx, & w440_band_indx, w670_band_indx logical :: w340_band_iz, w380_band_iz, & w440_band_iz, w670_band_iz end type solar_spectrum_type !--------------------------------------------------------------------- public surface_type ! asfc ! land type surface_type real, dimension(:,:), pointer :: asfc=>NULL(), & land=>NULL(), & asfc_vis_dir=>NULL(), & asfc_nir_dir=>NULL(), & asfc_vis_dif=>NULL(), & asfc_nir_dif=>NULL() end type surface_type !------------------------------------------------------------------- public sw_output_type ! dfsw ! ufsw ! fsw ! hsw ! dfswcf ! ufswcf ! fswcf ! hswcf ! swdn_special ! swup_special ! swdn_special_clr ! swup_special_clr type sw_output_type real, dimension(:,:,:,:), pointer :: dfsw=>NULL(), & ufsw=>NULL(), & fsw=>NULL(), & hsw=>NULL() real, dimension(:,:,:,:), pointer :: dfswcf=>NULL(), & ufswcf=>NULL(),& fswcf=>NULL(), & hswcf=>NULL() real, dimension(:,:,:), pointer :: dfsw_vis_sfc=>NULL(), & ufsw_vis_sfc=>NULL() real, dimension(:,:,:), pointer :: dfsw_dir_sfc=>NULL() real, dimension(:,:,:), pointer :: ufsw_dir_sfc=>NULL() real, dimension(:,:,:), pointer :: dfsw_dir_sfc_clr=>NULL() real, dimension(:,:,:), pointer :: dfsw_dif_sfc=>NULL(), & ufsw_dif_sfc=>NULL() real, dimension(:,:,:), pointer :: dfsw_dif_sfc_clr=>NULL() real, dimension(:,:,:), pointer :: dfsw_vis_sfc_dir=>NULL() real, dimension(:,:,:), pointer :: ufsw_vis_sfc_dir=>NULL() real, dimension(:,:,:), pointer :: dfsw_vis_sfc_clr=>NULL() real, dimension(:,:,:), pointer :: dfsw_vis_sfc_dif=>NULL(), & ufsw_vis_sfc_dif=>NULL() real, dimension(:,:,:,:), pointer :: bdy_flx=>NULL() real, dimension(:,:,:,:), pointer :: bdy_flx_clr=>NULL() real, dimension(:,:,:,:), pointer :: & swup_special=>NULL(), & swup_special_clr=>NULL() real, dimension(:,:,:,:), pointer :: swdn_special=>NULL(), & swdn_special_clr=>NULL() end type sw_output_type !------------------------------------------------------------------- public table_axis_type type table_axis_type integer :: first_col real :: min_val real :: max_val real :: tab_inc end type table_axis_type !--------------------------------------------------------------------- !private & !-------------------------------------------------------------------- !-------- namelist --------- integer :: dummy = 0 namelist / rad_utilities_nml / & dummy !--------------------------------------------------------------------- !------- public data ------ type (longwave_control_type), public :: & Lw_control = longwave_control_type( ' ', ' ', ' ', & .false., .false., .false., & .false., .false., .false., & .false., .false., & .false., .false., & .false., .false., .false., & .false., .false., & .false., .false., & .false., .false., .false. ) type (shortwave_control_type), public :: & Sw_control = shortwave_control_type( .false., .false., .false. , & .false., .false., .false., & .false., & 0.0, & .false., .false., .false. , & .false., & .false., .false., .false.) type (radiation_control_type), public :: & Rad_control = radiation_control_type( .false., .false., 0, 0, 0, & .false., .false., & .false., 1, & 0.0, .true., .false.,& .false., 0.0, & 0.0, .true., .false., & .false., 0.0, & 0.0, .true., .false., & .false., 0.0, & 0, .false., .false., & .false., .false.,& .false., .false., & 0, 0, .false., & ! _iz variables: .false., .false., .false., & .false., .false., .true., & .true., & .false., .false., & .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., & .false., .false., & .false., .false., & .false., & .false., .false., .false., & .false., .false., & .false., .false., & .false., .false., .false.) type (cloudrad_control_type), public :: & Cldrad_control = cloudrad_control_type( .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., & 0,0,0,0,0,0 , & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false., .false., .false., & .false. ) type (longwave_parameter_type), public :: & Lw_parameters = longwave_parameter_type( 0, 0, 0, 0, 0, 10.0, & .false., .false., .false., & .false., .false., .true.) type (table_axis_type), public :: & temp_1 = table_axis_type( 1, 100.0, 370.0, 10.0), & mass_1 = table_axis_type( 1, -16.0, 1.9, 0.1) !--------------------------------------------------------------------- !------- private data ------ logical :: module_is_initialized=.false. ! module is initialized ? !--------------------------------------------------------------------- !--------------------------------------------------------------------- contains !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! ! PUBLIC SUBROUTINES ! !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! ! ! Subroutine to initialize radiation utility package. ! ! ! This subroutine reads the input namelist file and initializes ! rad_utilities_nml. It then writes out this namelist to the output ! logfile. It also sets up the radiation calculation environment ! and the initialization flag variable. ! ! ! ! subroutine rad_utilities_init !--------------------------------------------------------------------- ! rad_utilities_init is the constructor for rad_uti;lities_mod. !--------------------------------------------------------------------- !------------------------------------------------------------------ ! local variables: integer :: unit, ierr, io, logunit !--------------------------------------------------------------------- ! local variables: ! ! unit io unit number used for namelist file ! ierr error code ! io error status returned from io operation ! !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! if routine has already been executed, exit. !--------------------------------------------------------------------- if (module_is_initialized) return !--------------------------------------------------------------------- ! verify that modules used by this module that are not called later ! have already been initialized. !--------------------------------------------------------------------- call fms_init !----------------------------------------------------------------------- ! read namelist. !----------------------------------------------------------------------- #ifdef INTERNAL_FILE_NML read (input_nml_file, nml=rad_utilities_nml, iostat=io) ierr = check_nml_error(io,'rad_utilities_nml') #else if ( file_exist('input.nml')) then unit = open_namelist_file ( ) ierr=1; do while (ierr /= 0) read (unit, nml=rad_utilities_nml, iostat=io, end=10) ierr = check_nml_error(io,'rad_utilities_nml') end do 10 call close_file (unit) endif #endif !--------------------------------------------------------------------- ! write version number and namelist to logfile. !--------------------------------------------------------------------- call write_version_number(version, tagname) logunit = stdlog() if (mpp_pe() == mpp_root_pe() ) & write (logunit, nml=rad_utilities_nml) !------------------------------------------------------------------- ! mark the module as initialized. !------------------------------------------------------------------- module_is_initialized = .true. !------------------------------------------------------------------ end subroutine rad_utilities_init !##################################################################### ! ! ! ! Subroutine to verify that all logical elements of derived-type ! variables were initialized during the initialization phase. ! ! ! This subroutine checks that all of the variable names ending in ! "_iz" in its public derived-type module variables are set to .true.. ! If additional types or variables within current public types are ! added, it is necessary to also add the corresponding "_iz" variable, ! initialized in this module to .false., and then set to .true. when ! the variable is initialized, and add a check in this routine to ! verify that initialization. ! ! ! ! subroutine check_derived_types !-------------------------------------------------------------------- ! check_derived_types is called at the end of radiation package ! initialization to verify that all logical components of public ! derived-type module variables have been initialized. !-------------------------------------------------------------------- !--------------------------------------------------------------------- ! check the components of Lw_control. !-------------------------------------------------------------------- if (Lw_control%do_cfc_iz .and. & Lw_control%do_lwaerosol_iz .and. & Lw_control%do_ch4_iz .and. & Lw_control%do_n2o_iz .and. & Lw_control%do_ch4lbltmpint_iz .and. & Lw_control%do_n2olbltmpint_iz .and. & Lw_control%do_co2_iz .and. & Lw_control%do_h2o_iz .and. & Lw_control%do_o3_iz .and. & Lw_control%do_lwcldemiss_iz ) then else call error_mesg ('rad_utilities_mod', & ' at least one component of Lw_control has not been '//& 'initialized', FATAL) endif !--------------------------------------------------------------------- ! check the components of Sw_control. !-------------------------------------------------------------------- if (Sw_control%do_lhsw_iz .and. & Sw_control%do_esfsw_iz .and. & Sw_control%do_swaerosol_iz .and. & Sw_control%do_diurnal_iz .and. & Sw_control%do_annual_iz .and. & Sw_control%do_cmip_diagnostics_iz .and. & Sw_control%do_daily_mean_iz ) then else call error_mesg ('rad_utilities_mod', & ' at least one component of Sw_control has not been '//& 'initialized', FATAL) endif !--------------------------------------------------------------------- ! check the components of Rad_control. !-------------------------------------------------------------------- if (Rad_control%do_totcld_forcing_iz .and. & Rad_control%do_lwaerosol_forcing_iz .and. & Rad_control%do_swaerosol_forcing_iz .and. & Rad_control%indx_lwaf_iz .and. & Rad_control%indx_swaf_iz .and. & Rad_control%using_im_bcsul_iz .and. & Rad_control%volcanic_sw_aerosols_iz .and. & Rad_control%volcanic_lw_aerosols_iz .and. & Rad_control%time_varying_solar_constant_iz .and. & Rad_control%using_solar_timeseries_data_iz .and. & Rad_control%do_aerosol_iz .and. & Rad_control%mx_spec_levs_iz .and. & Rad_control%use_current_co2_for_tf_iz .and. & Rad_control%co2_tf_calc_intrvl_iz .and. & Rad_control%calc_co2_tfs_on_first_step_iz .and. & Rad_control%calc_co2_tfs_monthly_iz .and. & Rad_control%co2_tf_time_displacement_iz .and. & Rad_control%use_current_ch4_for_tf_iz .and. & Rad_control%ch4_tf_calc_intrvl_iz .and. & Rad_control%calc_ch4_tfs_on_first_step_iz .and. & Rad_control%calc_ch4_tfs_monthly_iz .and. & Rad_control%ch4_tf_time_displacement_iz .and. & Rad_control%use_current_n2o_for_tf_iz .and. & Rad_control%n2o_tf_calc_intrvl_iz .and. & Rad_control%calc_n2o_tfs_on_first_step_iz .and. & Rad_control%calc_n2o_tfs_monthly_iz .and. & Rad_control%n2o_tf_time_displacement_iz .and. & Rad_control%do_lw_rad_iz .and. & Rad_control%do_sw_rad_iz .and. & Rad_control%nzens_iz .and. & Rad_control%hires_coszen_iz .and. & Rad_control%lw_rad_time_step_iz .and. & Rad_control%sw_rad_time_step_iz .and. & Rad_control%rad_time_step_iz ) then else call error_mesg ('rad_utilities_mod', & ' at least one component of Rad_control has not been '//& 'initialized', FATAL) endif !--------------------------------------------------------------------- ! check the components of Cldrad_control. !-------------------------------------------------------------------- if (Cldrad_control%do_pred_cld_microphys_iz .and. & Cldrad_control%do_presc_cld_microphys_iz .and. & Cldrad_control%do_bulk_microphys_iz .and. & Cldrad_control%do_sw_micro_iz .and. & Cldrad_control%do_lw_micro_iz .and. & Cldrad_control%do_strat_clouds_iz .and. & Cldrad_control%do_rh_clouds_iz .and. & Cldrad_control%do_zonal_clouds_iz .and. & Cldrad_control%do_mgroup_prescribed_iz .and. & Cldrad_control%do_obs_clouds_iz .and. & Cldrad_control%do_no_clouds_iz .and. & Cldrad_control%do_diag_clouds_iz .and. & Cldrad_control%do_specified_clouds_iz .and. & Cldrad_control%do_specified_strat_clouds_iz .and. & Cldrad_control%do_donner_deep_clouds_iz .and. & Cldrad_control%do_uw_clouds_iz .and. & Cldrad_control%do_zetac_clouds_iz .and. & Cldrad_control%do_stochastic_clouds_iz .and. & Cldrad_control%use_temp_for_seed_iz .and. & Cldrad_control%do_random_overlap_iz .and. & Cldrad_control%do_ica_calcs_iz .and. & Cldrad_control%using_fu2007_iz .and. & Cldrad_control%do_liq_num_iz .and. & Cldrad_control%do_ice_num_iz .and. & Cldrad_control%do_max_random_overlap_iz ) then else call error_mesg ('rad_utilities_mod', & ' at least one component of Cldrad_control has not been '//& 'initialized', FATAL) endif !--------------------------------------------------------------------- ! check the components of Lw_parameters. !-------------------------------------------------------------------- if (Lw_parameters%offset_iz .and. & Lw_parameters%nbtrg_iz .and. & Lw_parameters%nbtrge_iz .and. & Lw_parameters%nbly_iz .and. & Lw_parameters%n_lwaerosol_bands_iz .and. & Lw_parameters%lw_band_resolution_iz) then else call error_mesg ('rad_utilities_mod', & ' at least one component of Lw_parameters has not been '//& 'initialized', FATAL) endif !--------------------------------------------------------------------- ! check for consistency between band structure and cfc and lwaerosol ! effects. !--------------------------------------------------------------------- if (Lw_parameters%nbtrge == 0) then if (Lw_control%do_cfc .or. Lw_control%do_lwaerosol) then call error_mesg ('rad_utilities_mod', & 'when do_cfc and / or do_lwaerosol is .true., must set & &sealw99_nml variable no_h2o_bands_1200_1400 > 0 ', FATAL) endif endif !-------------------------------------------------------------------- !-------------------------------------------------------------------- end subroutine check_derived_types !#################################################################### ! ! ! Subroutine to locate index and residual value from an array provided ! with array and axis information ! ! ! given array x and an arithmetic sequence of table column headings ! tabxmin, tabxmin+tabdeltax, ..., corresponding to column ixlow, ! ixlow+1, ..., ixupp, Locate returns the array ix is column ! indices and the array dx of residuals. ! ! ! ! table_axis contains the axis information such as, min, increment, ! and first column values. ! ! ! array from which data is to be searched ! ! ! residual between x and x(ix+first_column) ! ! ! index values of the searched domain in the array ! ! ! minimum k value of the search domain ! ! ! maximum k value of the search domain ! ! subroutine locate_in_table (table_axis, x, dx, ix, k_min, k_max) !--------------------------------------------------------------------- ! given array x and an arithmetic sequence of table column headings ! tabxmin, tabxmin+tabdeltax, ..., corresponding to column ixlow, ! ixlow+1, ..., ixupp, locate_in_table returns the array ix of ! column indices and the array dx of residuals. ! author: c. h. goldberg ! revised: 1/1/93 ! certified: radiation version 1.0 !---------------------------------------------------------------------- type(table_axis_type), intent(in) :: table_axis real, dimension(:,:,:), intent(in) :: x integer, intent(in) :: k_min, k_max real, dimension(:,:,:), intent(out) :: dx integer, dimension(:,:,:), intent(out) :: ix !-------------------------------------------------------------------- ! intent(in) variables: ! ! table_axis ! x ! k_min ! k_max ! ! intent(out) variables: ! ! dx ! ix ! !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! local variables: real, dimension (size(x,1), size(x,2), size(x,3)) :: fx integer :: k !--------------------------------------------------------------------- ! local variables: ! ! fx ! table_min ! table_inc ! k ! table_col ! !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! be sure module has been initialized. !--------------------------------------------------------------------- if (.not. module_is_initialized ) then call error_mesg ('rad_utilities_mod', & 'module has not been initialized', FATAL ) endif !--------------------------------------------------------------------- ! !--------------------------------------------------------------------- do k=k_min,k_max fx (:,:,k) = AINT((x(:,:,k) - table_axis%min_val )/ & table_axis%tab_inc) ix (:,:,k) = INT(fx(:,:,k)) + table_axis%first_col dx (:,:,k) = x(:,:,k) - fx(:,:,k)*table_axis%tab_inc - & table_axis%min_val end do !--------------------------------------------------------------------- end subroutine locate_in_table !#################################################################### ! ! ! Subroutine to calculate answer from input differentials. ! ! ! given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and ! arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and ! y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:)) ! from four tables of values, f, df/dx, df/dy, and d2f/dxdy. ! ! ! ! The data array that contains function values and differentials ! ! ! x subscript of input data array ! ! ! y subscript of input data array ! ! ! x step in the x subscript space ! ! ! y step in the y subscript space ! ! ! the answer to be calculated ! ! ! the minimum k value of the domain ! ! ! the maximum k value of the domain ! ! ! subroutine looktab_type1 (tab, ix, iy, dx, dy, answer, k_min, k_max) !---------------------------------------------------------------------- ! given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and ! arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and ! y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:)) ! from four tables of values, f, df/dx, df/dy, and d2f/dxdy. ! author: c. h. goldberg ! revised: 1/1/93 ! certified: radiation version 1.0 !-------------------------------------------------------------------- type(longwave_tables1_type), intent(in) :: tab integer,dimension(:,:,:), intent(in) :: ix, iy real, dimension(:,:,:), intent(in) :: dx, dy real, dimension(:,:,:), intent(out) :: answer integer, intent(in) :: k_min, k_max !--------------------------------------------------------------------- ! intent(in) variables: ! ! tab ! ix ! iy ! dx ! dy ! k_min ! k_max ! ! intent(out) variables: ! ! answer ! !--------------------------------------------------------------------- !-------------------------------------------------------------------- ! local variables: integer :: i_min, i_max, j_min, j_max, i, j, k !-------------------------------------------------------------------- ! local variables: ! ! i_min ! i_max ! j_min ! j_max ! i,j,k ! !-------------------------------------------------------------------- !--------------------------------------------------------------------- ! be sure module has been initialized. !--------------------------------------------------------------------- if (.not. module_is_initialized ) then call error_mesg ('rad_utilities_mod', & 'module has not been initialized', FATAL ) endif i_min = lbound(ix,1) i_max = ubound(ix,1) j_min = lbound(ix,2) j_max = ubound(ix,2) do k=k_min, k_max do j=j_min, j_max do i=i_min, i_max answer(i,j,k) = & tab%vae (ix(i,j,k), iy(i,j,k)) + & dx(i,j,k)*tab%td (ix(i,j,k), iy(i,j,k)) + & dy(i,j,k)*tab%md (ix(i,j,k), iy(i,j,k)) + & dx(i,j,k)*dy(i,j,k)*tab%cd(ix(i,j,k), iy(i,j,k)) end do end do end do !--------------------------------------------------------------------- end subroutine looktab_type1 !##################################################################### ! ! ! Subroutine to calculate answer from input differentials. ! ! ! given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and ! arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and ! y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:)) ! from four tables of values, f, df/dx, df/dy, and d2f/dxdy. ! The difference between this version about the version above is ! that the differential arrays are 3 dimensional. ! ! ! ! The data array that contains function values and differentials ! ! ! x subscript of input data array ! ! ! y subscript of input data array ! ! ! x step in the x subscript space ! ! ! y step in the y subscript space ! ! ! the answer to be calculated ! ! ! the minimum k value of the domain ! ! ! the maximum k value of the domain ! ! ! the z indice of the differential arrays ! ! ! subroutine looktab_type2 (tab, ix, iy, dx, dy, answer, k_min, k_max, m) !------------------------------------------------------------------- ! given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and ! arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and ! y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:)) ! from four tables of values, f, df/dx, df/dy, and d2f/dxdy. ! author: c. h. goldberg ! revised: 1/1/93 ! certified: radiation version 1.0 !-------------------------------------------------------------------- type(longwave_tables2_type), intent(in) :: tab integer, dimension (:,:,:), intent(in) :: ix, iy integer, intent(in) :: m real, dimension (:,:,:), intent(in) :: dx, dy real, dimension (:,:,:), intent(out) :: answer integer, intent(in) :: k_min, k_max !--------------------------------------------------------------------- ! intent(in) variables: ! ! tab ! ix ! iy ! m ! dx ! dy ! k_min ! k_max ! ! intent(out) variables: ! ! answer ! !--------------------------------------------------------------------- !-------------------------------------------------------------------- ! local variables: integer :: i_min, i_max, j_min, j_max integer :: i, j, k !-------------------------------------------------------------------- ! local variables: ! ! i_min ! i_max ! j_min ! j_max ! i,j,k ! !------------------------------------------------------------------- !--------------------------------------------------------------------- ! be sure module has been initialized. !--------------------------------------------------------------------- if (.not. module_is_initialized ) then call error_mesg ('rad_utilities_mod', & 'module has not been initialized', FATAL ) endif i_min = lbound(ix,1) i_max = ubound(ix,1) j_min = lbound(ix,2) j_max = ubound(ix,2) do k=k_min, k_max do j=j_min, j_max do i=i_min, i_max answer(i,j,k) = & tab%vae (ix(i,j,k), iy(i,j,k),m) + & dx(i,j,k)*tab%td (ix(i,j,k), iy(i,j,k),m) + & dy(i,j,k)*tab%md (ix(i,j,k), iy(i,j,k),m) + & dx(i,j,k)*dy(i,j,k)*tab%cd (ix(i,j,k), iy(i,j,k),m) end do end do end do !-------------------------------------------------------------------- end subroutine looktab_type2 !################################################################### ! ! ! Subroutine to calculate answer from input differentials. ! ! ! given arrays ix(:,:,:) and iy(:,:,:) of integral subscripts and ! arrays dx(:,:,:) and dy(:,:,:) of differences from x(:,:,:) and ! y(:,:,:), calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:)) ! from four tables of values, f, df/dx, df/dy, and d2f/dxdy. ! In this version, only f(x,y) and f(x,y)+dx*df/dx is used. Probably ! the f(x,y) is homogeneous in y space. ! ! ! ! The data array that contains function values and differentials ! ! ! x subscript of input data array ! ! ! x step in the x subscript space ! ! ! the answer to be calculated ! ! ! the minimum k value of the domain ! ! ! the maximum k value of the domain ! ! ! the z indice of the differential arrays ! ! ! subroutine looktab_type3 (tab, ix, dx, answer, k_min, k_max, n) !---------------------------------------------------------------------- ! ! given arrays ix(:,:,:) and dx(:,:,:) of integer subscripts and! ! differences from x(:,:,:) and constant column subscript iyconst, ! calculate answer(:,:,:) = f(x(:,:,:), y(:,:,:)) from four tables ! of values f, df/dx, df/dy, and d2f/dxdy. ! author: c. h. goldberg ! revised: 1/1/93 ! certified: radiation version 1.0 !----------------------------------------------------------------------- type(longwave_tables3_type), intent(in) :: tab integer, dimension (:,:,:), intent(in) :: ix integer, intent(in) :: n real, dimension(:,:,:), intent(in) :: dx real, dimension(:,:,:), intent(out) :: answer integer, intent(in) :: k_min, k_max !--------------------------------------------------------------------- ! intent(in) variables: ! ! tab ! ix ! n ! dx ! k_min ! k_max ! ! intent(out) variables: ! ! answer ! !--------------------------------------------------------------------- !-------------------------------------------------------------------- ! local variables: integer :: i_min, i_max, j_min, j_max integer :: i, j, k !-------------------------------------------------------------------- ! local variables: ! ! i_min ! i_max ! j_min ! j_max ! i,j,k ! !------------------------------------------------------------------- !--------------------------------------------------------------------- ! be sure module has been initialized. !--------------------------------------------------------------------- if (.not. module_is_initialized ) then call error_mesg ('rad_utilities_mod', & 'module has not been initialized', FATAL ) endif !----------------------------------------------------------------- i_min = lbound(ix,1) i_max = ubound(ix,1) j_min = lbound(ix,2) j_max = ubound(ix,2) do k=k_min, k_max do j=j_min, j_max do i=i_min, i_max answer(i,j,k) = & tab%vae (ix(i,j,k),n) + & dx(i,j,k)*tab%td(ix(i,j,k),n) end do end do end do !------------------------------------------------------------------ end subroutine looktab_type3 !##################################################################### ! ! ! Allocate the longwave tables. ! ! ! Allocate the longwave tables based on 2 dimension sizes ! ! ! ! The longwave tables ! ! ! size of the x dimension ! ! ! size of the y dimension ! ! ! subroutine table1_alloc (tab, dim1, dim2) !------------------------------------------------------------------ ! table1_alloc allocates the arrays contained in a ! longwave_tables1_type variable. !------------------------------------------------------------------ type(longwave_tables1_type), intent (inout) :: tab integer, intent(in) :: dim1, dim2 !------------------------------------------------------------------- ! intent(in) variables: ! ! dim1 ! dim2 ! ! intent(inout) variables: ! ! tab ! !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! be sure module has been initialized. !--------------------------------------------------------------------- if (.not. module_is_initialized ) then call error_mesg ('rad_utilities_mod', & 'module has not been initialized', FATAL ) endif !--------------------------------------------------------------------- ! allocate the component arrays of a longwave_tables1_type variable. !--------------------------------------------------------------------- allocate (tab%vae(dim1, dim2)) allocate (tab%td (dim1, dim2)) allocate (tab%md (dim1, dim2)) allocate (tab%cd (dim1, dim2)) !--------------------------------------------------------------------- end subroutine table1_alloc !#################################################################### ! ! ! Allocate the longwave tables. ! ! ! Allocate the longwave tables based on 3 dimension sizes ! ! ! ! The longwave tables ! ! ! size of the x dimension ! ! ! size of the y dimension ! ! ! size of the z dimension ! ! ! subroutine table2_alloc (tab, dim1, dim2, dim3) !------------------------------------------------------------------ ! table2_alloc allocates the arrays contained in a ! longwave_tables2_type variable. !------------------------------------------------------------------ type(longwave_tables2_type), intent (inout) :: tab integer, intent(in) :: dim1, dim2, dim3 !------------------------------------------------------------------- ! intent(in) variables: ! ! dim1 ! dim2 ! dim3 ! ! intent(inout) variables: ! ! tab ! !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! be sure module has been initialized. !--------------------------------------------------------------------- if (.not. module_is_initialized ) then call error_mesg ('rad_utilities_mod', & 'module has not been initialized', FATAL ) endif !--------------------------------------------------------------------- ! allocate the component arrays of a longwave_tables2_type variable. !--------------------------------------------------------------------- allocate (tab%vae(dim1, dim2, dim3)) allocate (tab%td (dim1, dim2, dim3)) allocate (tab%md (dim1, dim2, dim3)) allocate (tab%cd (dim1, dim2, dim3)) !-------------------------------------------------------------------- end subroutine table2_alloc !##################################################################### ! ! ! Allocate the longwave tables. ! ! ! Allocate the longwave tables based on 2 dimension sizes ! ! ! ! The longwave tables ! ! ! size of the x dimension ! ! ! size of the y dimension ! ! ! subroutine table3_alloc (tab, dim1, dim2) type(longwave_tables3_type), intent (inout) :: tab integer, intent(in) :: dim1, dim2 !------------------------------------------------------------------- ! intent(in) variables: ! ! dim1 ! dim2 ! ! intent(inout) variables: ! ! tab ! !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! be sure module has been initialized. !--------------------------------------------------------------------- if (.not. module_is_initialized ) then call error_mesg ('rad_utilities_mod', & 'module has not been initialized', FATAL ) endif !--------------------------------------------------------------------- ! allocate the component arrays of a longwave_tables3_type variable. !--------------------------------------------------------------------- allocate (tab%vae(dim1, dim2)) allocate (tab%td (dim1, dim2)) end subroutine table3_alloc !################################################################## ! ! ! Subroutine to use thick-averaging technique to define band interval ! single scattering properties. ! ! ! use the thick-averaging technique to define the single-scattering ! properties of the parameterization band spectral intervals from the ! specified spectral intervals of the particular scatterer. ! ! references: ! ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. ! ! note: the 1.0E-100 factor to calculate asymmband is to prevent ! division by zero. ! ! ! ! interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! number of specified scattering spectral intervals ! ! ! number of spectral bands ! ! ! the specified spectral values of the extinction coefficient ! ! ! the specified spectral values of the single-scattering albedo ! ! ! the specified spectral values of the asymmetry factor ! ! ! the solar flux in each specified scattering spectral interval ! ! ! the solar flux in each parameterization band ! ! ! the parameterization band values of the extinction coefficient ! ! ! the parameterization band values of the single-scattering albedo ! ! ! the parameterization band values of the asymmetry factor ! ! ! subroutine thickavg_3d (nivl1, nivl2, nivls, nbands, extivl, ssalbivl,& asymmivl, solflxivl, solflxband, mask, extband,& ssalbband, asymmband) !--------------------------------------------------------------------- ! thickavg_3d uses the thick-averaging technique to define the ! single-scattering properties of the parameterization band spectral ! intervals from the specified spectral intervals of the particular ! scatterer, using 3d input arrays. ! references: ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. !-------------------------------------------------------------------- integer, dimension(:), intent(in) :: nivl1, nivl2 integer, intent(in) :: nivls integer, intent(in) :: nbands real, dimension(:,:,:,:), intent(in) :: extivl, asymmivl real, dimension(:,:,:,:), intent(inout) :: ssalbivl real, dimension(:,:), intent(in) :: solflxivl real, dimension(:), intent(in) :: solflxband real, dimension(:,:,:,:), intent(out) :: extband, ssalbband, & asymmband logical, dimension(:,:,:), intent(in) :: mask !--------------------------------------------------------------------- ! intent(in) variables: ! ! nivl1 interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! nivl2 interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! nivls number of specified scattering spectral intervals ! nbands ! extivl specified spectral values of the extinction coefficient ! asymmivl the specified spectral values of the asymmetry ! factor ! solflxivl the solar flux in each specified scattering spectral ! interval ! solflxband the solar flux in each parameterization band ! ! intent(inout) variables: ! ! ssalbivl the specified spectral values of the single- ! scattering albedo ! ! intent(out) variables: ! ! extband the parameterization band values of the extinction ! coefficient ! ssalbband the parameterization band values of the single- ! scattering albedo ! asymmband the parameterization band values of the asymmetry ! factor ! !-------------------------------------------------------------------- !-------------------------------------------------------------------- ! local variables: real, dimension (size(ssalbivl,1), & size(ssalbivl,2), & size(ssalbivl,3), nbands) :: refband real, dimension (size(ssalbivl,1), & size(ssalbivl,2), & size(ssalbivl,3)) :: refthick, sp, sumk, & sumomegak, sumomegakg, & sumrefthick integer :: nband integer :: i, j, k, ni !-------------------------------------------------------------------- ! local variables: ! ! refband ! refthick ! sp ! sumk ! sumomegak ! sumomegakg ! sumrefthck ! nband ! i,j,k,ni ! !-------------------------------------------------------------------- !------------------------------------------------------------------- ! be sure module has been initialized. !-------------------------------------------------------------------- if (.not. module_is_initialized) then call error_mesg ('rad_utilities_mod', & 'initialization routine of this module was never called', & FATAL) endif !------------------------------------------------------ -------------- !-------------------------------------------------------------------- do nband = 1,nbands sumk(:,:,:) = 0.0 sumomegak(:,:,:) = 0.0 sumomegakg(:,:,:) = 0.0 sumrefthick(:,:,:) = 0.0 do ni = nivl1(nband),nivl2(nband) ! do k=1, size(ssalbivl,3) do j=1,size(ssalbivl,2) do i=1,size(ssalbivl,1) if (mask(i,j,k)) then ssalbivl(i,j,k,ni) = MIN(ssalbivl(i,j,k,ni), 1.0) sp(i,j,k) = sqrt( ( 1.0 - ssalbivl(i,j,k,ni) ) / & ( 1.0 - ssalbivl(i,j,k,ni) * & asymmivl(i,j,k,ni) ) ) refthick(i,j,k) = (1.0 - sp(i,j,k))/(1.0 + sp(i,j,k)) sumrefthick(i,j,k) = sumrefthick(i,j,k) + & refthick(i,j,k)* & solflxivl(nband,ni) sumk(i,j,k) = sumk(i,j,k) + extivl(i,j,k,ni) * & solflxivl(nband,ni) sumomegak(i,j,k) = sumomegak(i,j,k) + & ssalbivl(i,j,k,ni)* & extivl(i,j,k,ni) * & solflxivl(nband,ni) sumomegakg(i,j,k) = sumomegakg(i,j,k) + & ssalbivl(i,j,k,ni)*& extivl(i,j,k,ni)* & asymmivl(i,j,k,ni) * & solflxivl(nband,ni) endif end do end do end do end do !--------------------------------------------------------------------- ! the 1.0E-100 factor to calculate asymmband is to prevent ! division by zero. !--------------------------------------------------------------------- do k=1, size(ssalbivl,3) do j=1,size(ssalbivl,2) do i=1,size(ssalbivl,1) extband(i,j,k,nband) = sumk(i,j,k) / solflxband(nband) asymmband(i,j,k,nband) = sumomegakg(i,j,k) / & ( sumomegak(i,j,k) + 1.0E-100) refband(i,j,k,nband) = sumrefthick(i,j,k)/ & solflxband(nband) ssalbband(i,j,k,nband) = 4.0 * refband(i,j,k,nband) / & ((1.0 + & refband(i,j,k,nband)) ** 2 -& asymmband(i,j,k,nband) * & (1.0 - refband(i,j,k,nband))**2 ) end do end do end do end do !--------------------------------------------------------------------- end subroutine thickavg_3d !#################################################################### ! ! ! Subroutine to use thick-averaging technique to define band interval ! single scattering properties. ! ! ! use the thick-averaging technique to define the single-scattering ! properties of the parameterization band spectral intervals from the ! specified spectral intervals of the particular scatterer. ! ! references: ! ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. ! ! note: the 1.0E-100 factor to calculate asymmband is to prevent ! division by zero. ! ! ! ! interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! number of specified scattering spectral intervals ! ! ! number of spectral bands ! ! ! the specified spectral values of the extinction coefficient ! ! ! the specified spectral values of the single-scattering albedo ! ! ! the specified spectral values of the asymmetry factor ! ! ! the solar flux in each specified scattering spectral interval ! ! ! the solar flux in each parameterization band ! ! ! the parameterization band values of the extinction coefficient ! ! ! the parameterization band values of the single-scattering albedo ! ! ! the parameterization band values of the asymmetry factor ! ! ! subroutine thickavg_0d (nivl1, nivl2, nivls, nbands, extivl, ssalbivl,& asymmivl, solflxivl, solflxband, extband, & ssalbband , asymmband) !--------------------------------------------------------------------- ! thickavg_0d uses the thick-averaging technique to define the ! single-scattering properties of the parameterization band spectral ! intervals from the specified spectral intervals of the particular ! scatterer, using 3d input arrays. ! references: ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. !-------------------------------------------------------------------- integer, dimension(:), intent(in) :: nivl1, nivl2 integer, intent(in) :: nivls integer, intent(in) :: nbands real, dimension(:), intent(in) :: extivl, asymmivl real, dimension(:), intent(inout) :: ssalbivl real, dimension(:,:), intent(in) :: solflxivl real, dimension(:), intent(in) :: solflxband real, dimension(:), intent(out) :: extband, ssalbband, & asymmband !--------------------------------------------------------------------- ! intent(in) variables: ! ! nivl1 interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! nivl2 interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! nivls number of specified scattering spectral intervals ! nbands ! extivl specified spectral values of the extinction coefficient ! asymmivl the specified spectral values of the asymmetry ! factor ! solflxivl the solar flux in each specified scattering spectral ! interval ! solflxband the solar flux in each parameterization band ! ! intent(inout) variables: ! ! ssalbivl the specified spectral values of the single- ! scattering albedo ! ! intent(out) variables: ! ! extband the parameterization band values of the extinction ! coefficient ! ssalbband the parameterization band values of the single- ! scattering albedo ! asymmband the parameterization band values of the asymmetry ! factor ! !-------------------------------------------------------------------- !-------------------------------------------------------------------- ! local variables: real, dimension (nbands) :: refband real :: refthick, sp, sumk, & sumomegak, sumomegakg, & sumrefthick integer :: nband integer :: ni !-------------------------------------------------------------------- ! local variables: ! ! refband ! refthick ! sp ! sumk ! sumomegak ! sumomegakg ! sumrefthck ! nband ! i,j,k,ni ! !-------------------------------------------------------------------- !------------------------------------------------------------------- ! be sure module has been initialized. !-------------------------------------------------------------------- if (.not. module_is_initialized) then call error_mesg ('rad_utilities_mod', & 'initialization routine of this module was never called', & FATAL) endif !---------------------------------------------------------------------- ! !---------------------------------------------------------------------- do nband = 1,nbands sumk = 0.0 sumomegak = 0.0 sumomegakg = 0.0 sumrefthick = 0.0 do ni = nivl1(nband),nivl2(nband) if (extivl(ni) /= 0.0) then ssalbivl(ni) = MIN(ssalbivl(ni), 1.0) sp = sqrt( ( 1.0 - ssalbivl(ni) ) / & ( 1.0 - ssalbivl(ni) * asymmivl(ni) ) ) refthick = (1.0 - sp)/(1.0 + sp) sumrefthick = sumrefthick + refthick * solflxivl(nband,ni) sumk = sumk + extivl(ni) * solflxivl(nband,ni) sumomegak = sumomegak + & ssalbivl(ni) * extivl(ni) * solflxivl(nband,ni) sumomegakg = sumomegakg + & ssalbivl(ni) * extivl(ni) * & asymmivl(ni) * solflxivl(nband,ni) endif end do !--------------------------------------------------------------------- ! !--------------------------------------------------------------------- extband(nband) = sumk / solflxband(nband) asymmband(nband) = sumomegakg / ( sumomegak + 1.0E-100) refband(nband) = sumrefthick/ solflxband(nband) ssalbband(nband) = 4.0 * refband(nband) / & ( (1.0 + refband(nband))**2 - & asymmband(nband) * (1.0 - refband(nband))**2 ) end do !--------------------------------------------------------------------- end subroutine thickavg_0d !################################################################## ! ! ! Subroutine to use thick-averaging technique to define band interval ! single scattering properties for a single specified band. ! ! ! use the thick-averaging technique to define the single-scattering ! properties of the specified parameterization band spectral interval ! from the specified spectral intervals of the particular scatterer. ! ! references: ! ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. ! ! note: the 1.0E-100 factor to calculate asymmband is to prevent ! division by zero. ! ! ! ! ! ! ! interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! the specified spectral values of the extinction coefficient ! ! ! the solar flux in each specified scattering spectral interval ! ! ! the solar flux in each parameterization band ! ! ! mask is .true. at gridpoints where extband needs to be calculated ! ! ! the parameterization band values of the extinction coefficient ! ! ! subroutine thickavg_isccp (nband, nivl1, nivl2, extivl, & solflxivl, solflxband, mask, extband) !--------------------------------------------------------------------- ! thickavg_isccp uses the thick-averaging technique to define the ! solar extinction for the single specified parameterization band ! spectral interval (nband) from the specified spectral intervals ! of the particular scatterer, using 3d input arrays. ! references: ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. !-------------------------------------------------------------------- integer, intent(in) :: nband integer, intent(in) :: nivl1, nivl2 real, dimension(:,:,:,:), intent(in) :: extivl real, dimension(:,:), intent(in) :: solflxivl real, intent(in) :: solflxband logical, dimension(:,:,:),intent(in) :: mask real, dimension(:,:,:), intent(out) :: extband !--------------------------------------------------------------------- ! intent(in) variables: ! ! nband the sw parameterization band for which the optical ! properties are being calculated ! nivl1 interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! nivl2 interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! extivl specified spectral values of the extinction coefficient ! solflxband the solar flux in each parameterization band ! mask logical indicating the points at which the band values ! should be calculated ! ! intent(out) variables: ! ! extband the parameterization band values of the extinction ! coefficient ! !-------------------------------------------------------------------- !-------------------------------------------------------------------- ! local variables: real :: sumk integer :: i, j, k, ni !-------------------------------------------------------------------- ! local variables: ! ! sumk ! i,j,k,ni ! !-------------------------------------------------------------------- !------------------------------------------------------------------- ! be sure module has been initialized. !-------------------------------------------------------------------- if (.not. module_is_initialized) then call error_mesg ('rad_utilities_mod', & 'initialization routine of this module was never called', & FATAL) endif !-------------------------------------------------------------------- ! do k=1, size(extivl,3) do j=1,size(extivl,2) do i=1,size(extivl,1) if (mask(i,j,k)) then sumk = 0.0 do ni = nivl1,nivl2 sumk = sumk + extivl(i,j,k,ni)*solflxivl(nband,ni) end do extband(i,j,k) = sumk/solflxband endif end do end do end do !--------------------------------------------------------------------- end subroutine thickavg_isccp !################################################################## ! ! ! Subroutine to use thick-averaging technique to define band interval ! single scattering properties for a single specified band. ! ! ! use the thick-averaging technique to define the single-scattering ! properties of the specified parameterization band spectral interval ! from the specified spectral intervals of the particular scatterer. ! ! references: ! ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. ! ! note: the 1.0E-100 factor to calculate asymmband is to prevent ! division by zero. ! ! ! ! ! ! ! interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! number of specified scattering spectral intervals ! ! ! number of spectral bands ! ! ! the specified spectral values of the extinction coefficient ! ! ! the specified spectral values of the single-scattering albedo ! ! ! the specified spectral values of the asymmetry factor ! ! ! the solar flux in each specified scattering spectral interval ! ! ! the solar flux in each parameterization band ! ! ! mask is .true. at gridpoints where band calculations are needed ! ! ! the parameterization band values of the extinction coefficient ! ! ! the parameterization band values of the single-scattering albedo ! ! ! the parameterization band values of the asymmetry factor ! ! ! subroutine thickavg_1band (nband, nivl1, nivl2, nivls, nbands, extivl, & ssalbivl, asymmivl, solflxivl, solflxband, & mask, extband, ssalbband, asymmband) !--------------------------------------------------------------------- ! thickavg_1band uses the thick-averaging technique to define the ! single-scattering properties of the specified parameterization band ! spectral interval from the specified spectral intervals of the ! particular scatterer, using 3d input arrays. ! references: ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. !-------------------------------------------------------------------- integer, intent(in) :: nband integer, intent(in) :: nivl1, nivl2 integer, intent(in) :: nivls integer, intent(in) :: nbands real, dimension(:,:,:,:), intent(in) :: extivl, asymmivl real, dimension(:,:,:,:), intent(inout) :: ssalbivl real, dimension(:,:), intent(in) :: solflxivl real, intent(in) :: solflxband real, dimension(:,:,: ), intent(inout) :: extband, ssalbband, & asymmband logical, dimension(:,:,:), intent(in) :: mask !--------------------------------------------------------------------- ! intent(in) variables: ! ! nband the sw parameterization band for which the optical ! properties are being calculated ! nivl1 interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! nivl2 interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! nivls number of specified scattering spectral intervals ! nbands ! extivl specified spectral values of the extinction coefficient ! asymmivl the specified spectral values of the asymmetry ! factor ! solflxivl the solar flux in each specified scattering spectral ! interval ! solflxband the solar flux in each parameterization band ! mask logical indicating the points at which the band values ! should be calculated ! ! intent(inout) variables: ! ! ssalbivl the specified spectral values of the single- ! scattering albedo ! ! intent(out) variables: ! ! extband the parameterization band values of the extinction ! coefficient ! ssalbband the parameterization band values of the single- ! scattering albedo ! asymmband the parameterization band values of the asymmetry ! factor ! !-------------------------------------------------------------------- !-------------------------------------------------------------------- ! local variables: real :: refband, sp, refthick real :: sumk, sumomegak, sumomegakg, sumrefthick integer :: i, j, k, ni !-------------------------------------------------------------------- ! local variables: ! ! refband ! refthick ! sp ! sumk ! sumomegak ! sumomegakg ! sumrefthck ! nband ! i,j,k,ni ! !-------------------------------------------------------------------- !------------------------------------------------------------------- ! be sure module has been initialized. !-------------------------------------------------------------------- if (.not. module_is_initialized) then call error_mesg ('rad_utilities_mod', & 'initialization routine of this module was never called', & FATAL) endif !-------------------------------------------------------------------- ! !-------------------------------------------------------------------- do k=1, size(ssalbivl,3) do j=1,size(ssalbivl,2) do i=1,size(ssalbivl,1) if (mask(i,j,k)) then sumk = 0.0 sumomegak = 0.0 sumomegakg = 0.0 sumrefthick = 0.0 do ni = nivl1,nivl2 ssalbivl(i,j,k,ni) = MIN(ssalbivl(i,j,k,ni), 1.0) sp = sqrt((1.0 - ssalbivl(i,j,k,ni) ) / & (1.0 - ssalbivl(i,j,k,ni)*asymmivl(i,j,k,ni))) refthick = (1.0 - sp)/(1.0 + sp) sumrefthick = sumrefthick + refthick*solflxivl(nband,ni) sumk = sumk + extivl(i,j,k,ni)*solflxivl(nband,ni) sumomegak = sumomegak + ssalbivl(i,j,k,ni)* & extivl(i,j,k,ni)* & solflxivl(nband,ni) sumomegakg = sumomegakg + ssalbivl(i,j,k,ni)*& extivl(i,j,k,ni)* & asymmivl(i,j,k,ni)* & solflxivl(nband,ni) end do !--------------------------------------------------------------------- ! the 1.0E-100 factor to calculate asymmband is to prevent ! division by zero. !--------------------------------------------------------------------- extband(i,j,k) = sumk/solflxband asymmband(i,j,k) = sumomegakg/(sumomegak + 1.0E-100) refband = sumrefthick/solflxband ssalbband(i,j,k) = 4.0*refband/((1.0 + refband) ** 2 - & asymmband(i,j,k)*(1.0 - refband)**2 ) endif end do end do end do !--------------------------------------------------------------------- end subroutine thickavg_1band !#################################################################### ! ! ! Subroutine to use thin-averaging technique to define band interval ! single scattering properties. ! ! ! use the thin-averaging technique to define the single-scattering ! properties of the parameterization band spectral intervals from the ! specified spectral intervals of the particular scatterer. ! ! references: ! ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. ! ! note: the 1.0E-100 factor to calculate asymmband is to prevent ! division by zero. ! ! ! ! interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! ! ! number of specified scattering spectral intervals ! ! ! the specified spectral values of the extinction coefficient ! ! ! number of spectral bands ! ! ! the specified spectral values of the single-scattering albedo ! ! ! the specified spectral values of the asymmetry factor ! ! ! the solar flux in each specified scattering spectral interval ! ! ! the solar flux in each parameterization band ! ! ! the parameterization band values of the extinction coefficient ! ! ! the parameterization band values of the single-scattering albedo ! ! ! the parameterization band values of the asymmetry factor ! ! ! subroutine thinavg (nivl1, nivl2, nivls, nbands, extivl, ssalbivl, & asymmivl, solflxivl, solflxband, extband, & ssalbband , asymmband) !--------------------------------------------------------------------- ! thinavg uses the thin-averaging technique to define the ! single-scattering properties of the parameterization band spectral ! intervals from the specified spectral intervals of the particular ! scatterer, using 3d input arrays. ! references: ! edwards,j.m. and a. slingo, studies with a flexible new radiation ! code I: choosing a configuration for a large-scale model., ! q.j.r. meteorological society, 122, 689-719, 1996. !-------------------------------------------------------------------- integer, dimension(:), intent(in) :: nivl1, nivl2 integer, intent(in) :: nivls integer, intent(in) :: nbands real, dimension(:,:,:,:), intent(in) :: extivl, asymmivl real, dimension(:,:,:,:), intent(inout) :: ssalbivl real, dimension(:,:), intent(in) :: solflxivl real, dimension(:), intent(in) :: solflxband real, dimension(:,:,:,:), intent(out) :: extband, ssalbband, & asymmband !--------------------------------------------------------------------- ! intent(in) variables: ! ! nivl1 interval number for the specified single-scattering ! properties corresponding to the first psuedo- ! monochromatic frequency in a given parameterization ! band ! nivl2 interval number for the specified single-scattering ! properties corresponding to the last psuedo- ! monochromatic frequency in a given parameterization ! band ! nivls number of specified scattering spectral intervals ! nbands ! extivl specified spectral values of the extinction coefficient ! asymmivl the specified spectral values of the asymmetry ! factor ! solflxivl the solar flux in each specified scattering spectral ! interval ! solflxband the solar flux in each parameterization band ! ! intent(inout) variables: ! ! ssalbivl the specified spectral values of the single- ! scattering albedo ! ! intent(out) variables: ! ! extband the parameterization band values of the extinction ! coefficient ! ssalbband the parameterization band values of the single- ! scattering albedo ! asymmband the parameterization band values of the asymmetry ! factor ! !-------------------------------------------------------------------- !-------------------------------------------------------------------- ! local variables: real, dimension (size(ssalbivl,1), & size(ssalbivl,2), & size(ssalbivl,3)) :: sumk, sumomegak, & sumomegakg integer :: nband integer :: i, j, k, ni !-------------------------------------------------------------------- ! local variables: ! ! sumk ! sumomegak ! sumomegakg ! nband ! i,j,k,ni ! !-------------------------------------------------------------------- !------------------------------------------------------------------- ! be sure module has been initialized. !-------------------------------------------------------------------- if (.not. module_is_initialized) then call error_mesg ('rad_utilities_mod', & 'initialization routine of this module was never called', & FATAL) endif !--------------------------------------------------------------------- ! !--------------------------------------------------------------------- do nband = 1,nbands sumk(:,:,:) = 0.0 sumomegak(:,:,:) = 0.0 sumomegakg(:,:,:) = 0.0 do ni = nivl1(nband),nivl2(nband) do k=1, size(ssalbivl,3) do j=1,size(ssalbivl,2) do i=1,size(ssalbivl,1) if ((ssalbivl(i,j,k,ni) + & asymmivl(i,j,k,ni)) /= 0.0) then ssalbivl(i,j,k,ni) = MIN(ssalbivl(i,j,k,ni), 1.0) sumk(i,j,k) = sumk(i,j,k) + extivl(i,j,k,ni) * & solflxivl(nband,ni) sumomegak(i,j,k) = sumomegak(i,j,k) + & ssalbivl(i,j,k,ni) * & extivl(i,j,k,ni) * & solflxivl(nband,ni) sumomegakg(i,j,k) = sumomegakg(i,j,k) + & ssalbivl(i,j,k,ni) * & extivl(i,j,k,ni) * & asymmivl(i,j,k,ni) * & solflxivl(nband,ni) endif end do end do end do end do !---------------------------------------------------------------------- ! !--------------------------------------------------------------------- do k=1, size(ssalbivl,3) do j=1,size(ssalbivl,2) do i=1,size(ssalbivl,1) extband(i,j,k,nband) = sumk(i,j,k) / solflxband(nband) asymmband(i,j,k,nband) = sumomegakg(i,j,k) / & ( sumomegak(i,j,k) + 1.0E-100 ) ssalbband(i,j,k,nband) = sumomegak(i,j,k) / & ( sumk(i,j,k) + 1.0E-100 ) end do end do end do end do !------------------------------------------------------------------- end subroutine thinavg !######################################################################### subroutine get_radiative_param(text_in_scheme,text_in_param, & rad_forc_online, tr_rad_name, & tr_clim_name, tr_rad_scale_factor) character(len=*), intent(in) :: text_in_scheme, text_in_param logical, intent(out) :: rad_forc_online character(len=*), intent(out) :: tr_rad_name,tr_clim_name real, intent(out) :: tr_rad_scale_factor integer :: flag if(lowercase(trim(text_in_scheme(1:6))) == 'online') then rad_forc_online = .true. flag=parse(text_in_param,'name_in_rad_mod', tr_rad_name) flag=parse(text_in_param,'name_in_clim_mod', tr_clim_name) tr_rad_scale_factor = 1. flag=parse(text_in_param,'scale_factor', tr_rad_scale_factor) else rad_forc_online = .false. tr_rad_name = ' ' tr_clim_name = ' ' tr_rad_scale_factor = 1. endif end subroutine get_radiative_param !##################################################################### ! ! ! Subroutine to close out the radiation utility package. ! ! ! This subroutine is the destructor for rad_utilies_mod. it marks ! the module as uninitialized. ! ! ! ! subroutine rad_utilities_end !-------------------------------------------------------------------- ! rad_utilites_end is the destructor for rad_utilities_mod. !--------------------------------------------------------------------- !--------------------------------------------------------------------- ! be sure module has been initialized. !--------------------------------------------------------------------- if (.not. module_is_initialized ) then call error_mesg ('rad_utilites_mod', & 'module has not been initialized', FATAL ) endif !--------------------------------------------------------------------- ! mark the module as uninitialized. !--------------------------------------------------------------------- module_is_initialized = .false. !------------------------------------------------------------------- end subroutine rad_utilities_end subroutine aerosol_props_type_eq(aerosol_props_out,aerosol_props_in) type(aerosol_properties_type), intent(inout) :: aerosol_props_out type(aerosol_properties_type), intent(in) :: aerosol_props_in ! Need to add error trap to catch unallocated aerosol_props_in if (ASSOCIATED(aerosol_props_in%aerextband)) then aerosol_props_out%aerextband = aerosol_props_in%aerextband aerosol_props_out%aerssalbband = aerosol_props_in%aerssalbband aerosol_props_out%aerasymmband = aerosol_props_in%aerasymmband else call error_mesg ('=', 'extband', FATAL) endif if (ASSOCIATED(aerosol_props_in%aerextbandlw)) then aerosol_props_out%aerextbandlw = aerosol_props_in%aerextbandlw aerosol_props_out%aerssalbbandlw = aerosol_props_in%aerssalbbandlw aerosol_props_out%aerextbandlw_cn = & aerosol_props_in%aerextbandlw_cn aerosol_props_out%aerssalbbandlw_cn = & aerosol_props_in%aerssalbbandlw_cn else call error_mesg ('=', 'extbandlw', FATAL) endif if (Rad_control%volcanic_sw_aerosols) then if (ASSOCIATED(aerosol_props_in%sw_ext)) then aerosol_props_out%sw_ext = aerosol_props_in%sw_ext aerosol_props_out%sw_ssa = aerosol_props_in%sw_ssa aerosol_props_out%sw_asy = aerosol_props_in%sw_asy else call error_mesg ('=', 'sw volc', FATAL) endif endif if (Rad_control%volcanic_lw_aerosols) then if (ASSOCIATED(aerosol_props_in%lw_ext)) then aerosol_props_out%lw_ext = aerosol_props_in%lw_ext aerosol_props_out%lw_ssa = aerosol_props_in%lw_ssa aerosol_props_out%lw_asy = aerosol_props_in%lw_asy else call error_mesg ('=', 'lw volc', FATAL) endif endif if (ASSOCIATED(aerosol_props_in%sulfate_index)) then aerosol_props_out%sulfate_index = aerosol_props_in%sulfate_index aerosol_props_out%optical_index = aerosol_props_in%optical_index aerosol_props_out%omphilic_index = aerosol_props_in%omphilic_index aerosol_props_out%bcphilic_index = aerosol_props_in%bcphilic_index aerosol_props_out%seasalt1_index = aerosol_props_in%seasalt1_index aerosol_props_out%seasalt2_index = aerosol_props_in%seasalt2_index aerosol_props_out%seasalt3_index = aerosol_props_in%seasalt3_index aerosol_props_out%seasalt4_index = aerosol_props_in%seasalt4_index aerosol_props_out%seasalt5_index = aerosol_props_in%seasalt5_index else call error_mesg ('=', 'index ', FATAL) endif if (ASSOCIATED(aerosol_props_in%ivol)) then aerosol_props_out%ivol = aerosol_props_in%ivol else call error_mesg ('=', 'ivol ', FATAL) endif aerosol_props_out%sulfate_flag = aerosol_props_in%sulfate_flag aerosol_props_out%omphilic_flag = aerosol_props_in%omphilic_flag aerosol_props_out%bcphilic_flag = aerosol_props_in%bcphilic_flag aerosol_props_out%seasalt1_flag = aerosol_props_in%seasalt1_flag aerosol_props_out%seasalt2_flag = aerosol_props_in%seasalt2_flag aerosol_props_out%seasalt3_flag = aerosol_props_in%seasalt3_flag aerosol_props_out%seasalt4_flag = aerosol_props_in%seasalt4_flag aerosol_props_out%seasalt5_flag = aerosol_props_in%seasalt5_flag aerosol_props_out%bc_flag = aerosol_props_in%bc_flag end subroutine aerosol_props_type_eq subroutine lw_output_type_eq(lw_output_out,lw_output_in) type(lw_output_type), intent(inout) :: lw_output_out type(lw_output_type), intent(in) :: lw_output_in ! Need to add error trap to catch unallocated lw_output_in lw_output_out%heatra = lw_output_in%heatra lw_output_out%flxnet = lw_output_in%flxnet lw_output_out%netlw_special = lw_output_in%netlw_special lw_output_out%bdy_flx = lw_output_in%bdy_flx if (ASSOCIATED(lw_output_in%heatracf))then lw_output_out%heatracf = lw_output_in%heatracf lw_output_out%flxnetcf = lw_output_in%flxnetcf lw_output_out%netlw_special_clr = lw_output_in%netlw_special_clr lw_output_out%bdy_flx_clr = lw_output_in%bdy_flx_clr endif end subroutine lw_output_type_eq subroutine sw_output_type_eq(sw_output_out,sw_output_in) type(sw_output_type), intent(inout) :: sw_output_out type(sw_output_type), intent(in) :: sw_output_in ! Need to add error trap to catch unallocated sw_output_in sw_output_out%fsw = sw_output_in%fsw sw_output_out%dfsw = sw_output_in%dfsw sw_output_out%ufsw = sw_output_in%ufsw sw_output_out%hsw = sw_output_in%hsw sw_output_out%dfsw_dir_sfc = sw_output_in%dfsw_dir_sfc sw_output_out%ufsw_dir_sfc = sw_output_in%ufsw_dir_sfc sw_output_out%dfsw_dif_sfc = sw_output_in%dfsw_dif_sfc sw_output_out%ufsw_dif_sfc = sw_output_in%ufsw_dif_sfc sw_output_out%dfsw_vis_sfc = sw_output_in%dfsw_vis_sfc sw_output_out%ufsw_vis_sfc = sw_output_in%ufsw_vis_sfc sw_output_out%ufsw_vis_sfc_dir = sw_output_in%ufsw_vis_sfc_dir sw_output_out%dfsw_vis_sfc_dir = sw_output_in%dfsw_vis_sfc_dir sw_output_out%dfsw_vis_sfc_dif = sw_output_in%dfsw_vis_sfc_dif sw_output_out%ufsw_vis_sfc_dif = sw_output_in%ufsw_vis_sfc_dif sw_output_out%swdn_special = sw_output_in%swdn_special sw_output_out%swup_special = sw_output_in%swup_special sw_output_out%bdy_flx = sw_output_in%bdy_flx if (ASSOCIATED(sw_output_in%fswcf))then sw_output_out%fswcf = sw_output_in%fswcf sw_output_out%dfswcf = sw_output_in%dfswcf sw_output_out%ufswcf = sw_output_in%ufswcf sw_output_out%hswcf = sw_output_in%hswcf sw_output_out%dfsw_dir_sfc_clr = sw_output_in%dfsw_dir_sfc_clr sw_output_out%dfsw_dif_sfc_clr = sw_output_in%dfsw_dif_sfc_clr sw_output_out%dfsw_vis_sfc_clr = sw_output_in%dfsw_vis_sfc_clr sw_output_out%swdn_special_clr = sw_output_in%swdn_special_clr sw_output_out%swup_special_clr = sw_output_in%swup_special_clr sw_output_out%bdy_flx_clr = sw_output_in%bdy_flx_clr endif end subroutine sw_output_type_eq !#################################################################### end module rad_utilities_mod