From 5e50bdfa18779f6b9f4728d759c81fca40640297 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 10 Feb 2021 00:19:10 +0000 Subject: [PATCH 01/12] Cleanup for MPI implementation. --- physics/GFS_rrtmgp_gfdlmp_pre.F90 | 3 +- physics/GFS_rrtmgp_pre.F90 | 145 ++++------ physics/GFS_rrtmgp_pre.meta | 45 +-- physics/GFS_rrtmgp_sw_post.F90 | 5 +- physics/GFS_rrtmgp_sw_post.meta | 8 - physics/GFS_rrtmgp_sw_pre.F90 | 5 +- physics/GFS_rrtmgp_sw_pre.meta | 8 - physics/GFS_rrtmgp_thompsonmp_pre.F90 | 3 +- physics/rrtmgp_lw_aerosol_optics.F90 | 8 +- physics/rrtmgp_lw_aerosol_optics.meta | 16 -- physics/rrtmgp_lw_cloud_optics.F90 | 310 ++++++++++---------- physics/rrtmgp_lw_cloud_optics.meta | 60 ++-- physics/rrtmgp_lw_cloud_sampling.F90 | 10 +- physics/rrtmgp_lw_cloud_sampling.meta | 16 -- physics/rrtmgp_lw_gas_optics.F90 | 305 ++++++++++---------- physics/rrtmgp_lw_gas_optics.meta | 48 ++-- physics/rrtmgp_lw_pre.F90 | 5 +- physics/rrtmgp_lw_pre.meta | 8 - physics/rrtmgp_lw_rte.F90 | 6 +- physics/rrtmgp_lw_rte.meta | 8 - physics/rrtmgp_sw_aerosol_optics.F90 | 8 +- physics/rrtmgp_sw_aerosol_optics.meta | 16 -- physics/rrtmgp_sw_cloud_optics.F90 | 319 ++++++++++----------- physics/rrtmgp_sw_cloud_optics.meta | 53 ++-- physics/rrtmgp_sw_cloud_sampling.F90 | 11 +- physics/rrtmgp_sw_cloud_sampling.meta | 16 -- physics/rrtmgp_sw_gas_optics.F90 | 390 ++++++++++++++------------ physics/rrtmgp_sw_gas_optics.meta | 82 +++--- physics/rrtmgp_sw_rte.F90 | 6 +- physics/rrtmgp_sw_rte.meta | 8 - 30 files changed, 899 insertions(+), 1032 deletions(-) diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.F90 b/physics/GFS_rrtmgp_gfdlmp_pre.F90 index 16844304b..1f3d34973 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.F90 +++ b/physics/GFS_rrtmgp_gfdlmp_pre.F90 @@ -6,7 +6,8 @@ module GFS_rrtmgp_gfdlmp_pre use machine, only: kind_phys use rrtmgp_aux, only: check_error_msg use module_radiation_cloud_overlap, only: cmp_dcorr_lgth, get_alpha_exp - use rrtmgp_lw_cloud_optics, only: radliq_lwr, radliq_upr, radice_lwr, radice_upr + use rrtmgp_lw_cloud_optics, only: radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& + radice_lwr => radice_lwrLW, radice_upr => radice_uprLW ! Parameters real(kind_phys), parameter :: & diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 73828999f..eb5ae91ce 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -8,7 +8,6 @@ module GFS_rrtmgp_pre getgases, & ! Routine to setup trace gases getozn ! Routine to setup ozone ! RRTMGP types - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_gas_concentrations, only: ty_gas_concs use rrtmgp_aux, only: check_error_msg @@ -19,20 +18,7 @@ module GFS_rrtmgp_pre amdw = amd/amw, & ! Molecular weight of dry air / water vapor amdo3 = amd/amo3 ! Molecular weight of dry air / ozone - ! Some common trace gas on/off flags. - ! This allows for control over which trace gases are used in RRTMGP radiation scheme via - ! namelist. - logical :: & - isActive_h2o = .false., & ! - isActive_co2 = .false., & ! - isActive_o3 = .false., & ! - isActive_n2o = .false., & ! - isActive_ch4 = .false., & ! - isActive_o2 = .false., & ! - isActive_ccl4 = .false., & ! - isActive_cfc11 = .false., & ! - isActive_cfc12 = .false., & ! - isActive_cfc22 = .false. ! + ! Save trace gas indices. integer :: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, iStr_o2, iStr_ccl4, & iStr_cfc11, iStr_cfc12, iStr_cfc22 @@ -45,15 +31,15 @@ module GFS_rrtmgp_pre !! \section arg_table_GFS_rrtmgp_pre_init !! \htmlinclude GFS_rrtmgp_pre_init.html !! - subroutine GFS_rrtmgp_pre_init(nGases, active_gases, active_gases_array, errmsg, errflg) + subroutine GFS_rrtmgp_pre_init(nGases, active_gases, gas_concentrations, errmsg, errflg) ! Inputs - integer, intent(in) :: & - nGases ! Number of active gases in RRTMGP - character(len=*), intent(in) :: & - active_gases ! List of active gases from namelist. + integer, intent(in) :: & + nGases ! Number of active gases in RRTMGP + character(len=*), intent(in) :: & + active_gases ! List of active gases from namelist. ! Outputs - character(len=*),dimension(nGases), intent(out) :: & - active_gases_array ! Character array containing trace gases to include in RRTMGP + type(ty_gas_concs),intent(out) :: & + gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & @@ -63,6 +49,7 @@ subroutine GFS_rrtmgp_pre_init(nGases, active_gases, active_gases_array, errmsg, character(len=1) :: tempstr integer :: ij, count integer,dimension(nGases,2) :: gasIndices + character(len=32),dimension(nGases) :: active_gases_array ! Initialize errmsg = '' @@ -89,51 +76,33 @@ subroutine GFS_rrtmgp_pre_init(nGases, active_gases, active_gases_array, errmsg, ! Now extract the gas names do ij=1,nGases active_gases_array(ij) = active_gases(gasIndices(ij,1):gasIndices(ij,2)) + if(trim(active_gases_array(ij)) .eq. 'h2o') istr_h2o = ij + if(trim(active_gases_array(ij)) .eq. 'co2') istr_co2 = ij + if(trim(active_gases_array(ij)) .eq. 'o3') istr_o3 = ij + if(trim(active_gases_array(ij)) .eq. 'n2o') istr_n2o = ij + if(trim(active_gases_array(ij)) .eq. 'ch4') istr_ch4 = ij + if(trim(active_gases_array(ij)) .eq. 'o2') istr_o2 = ij + if(trim(active_gases_array(ij)) .eq. 'ccl4') istr_ccl4 = ij + if(trim(active_gases_array(ij)) .eq. 'cfc11') istr_cfc11 = ij + if(trim(active_gases_array(ij)) .eq. 'cfc12') istr_cfc12 = ij + if(trim(active_gases_array(ij)) .eq. 'cfc22') istr_cfc22 = ij enddo - ! Which gases are active? (This is purely for flexibility) - do ij=1,nGases - if(trim(active_gases_array(ij)) .eq. 'h2o') then - isActive_h2o = .true. - istr_h2o = ij - endif - if(trim(active_gases_array(ij)) .eq. 'co2') then - isActive_co2 = .true. - istr_co2 = ij - endif - if(trim(active_gases_array(ij)) .eq. 'o3') then - isActive_o3 = .true. - istr_o3 = ij - endif - if(trim(active_gases_array(ij)) .eq. 'n2o') then - isActive_n2o = .true. - istr_n2o = ij - endif - if(trim(active_gases_array(ij)) .eq. 'ch4') then - isActive_ch4 = .true. - istr_ch4 = ij - endif - if(trim(active_gases_array(ij)) .eq. 'o2') then - isActive_o2 = .true. - istr_o2 = ij - endif - if(trim(active_gases_array(ij)) .eq. 'ccl4') then - isActive_ccl4 = .true. - istr_ccl4 = ij - endif - if(trim(active_gases_array(ij)) .eq. 'cfc11') then - isActive_cfc11 = .true. - istr_cfc11 = ij - endif - if(trim(active_gases_array(ij)) .eq. 'cfc12') then - isActive_cfc12 = .true. - istr_cfc12 = ij - endif - if(trim(active_gases_array(ij)) .eq. 'cfc22') then - isActive_cfc22 = .true. - istr_cfc22 = ij - endif - enddo + ! Initialze RRTMGP DDTs + call check_error_msg('GFS_rrtmgp_pre_init', & + gas_concentrations%init( active_gases_array)) + call check_error_msg('GFS_rrtmgp_pre_setvmr_h2o',& + gas_concentrations%set_vmr(active_gases_array(iStr_o2), 0._kind_phys)) + call check_error_msg('GFS_rrtmgp_pre_setvmr_co2',& + gas_concentrations%set_vmr(active_gases_array(iStr_co2), 0._kind_phys)) + call check_error_msg('GFS_rrtmgp_pre_setvmr_ch4',& + gas_concentrations%set_vmr(active_gases_array(iStr_ch4), 0._kind_phys)) + call check_error_msg('GFS_rrtmgp_pre_setvmr_n2o',& + gas_concentrations%set_vmr(active_gases_array(iStr_n2o), 0._kind_phys)) + call check_error_msg('GFS_rrtmgp_pre_setvmr_h2o',& + gas_concentrations%set_vmr(active_gases_array(iStr_h2o), 0._kind_phys)) + call check_error_msg('GFS_rrtmgp_pre_setvmr_o3', & + gas_concentrations%set_vmr(active_gases_array(iStr_o3), 0._kind_phys)) end subroutine GFS_rrtmgp_pre_init @@ -143,25 +112,23 @@ end subroutine GFS_rrtmgp_pre_init !> \section arg_table_GFS_rrtmgp_pre_run !! \htmlinclude GFS_rrtmgp_pre_run.html !! - subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, fhswr, & - fhlwr, xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, active_gases_array, con_eps,& - con_epsm1, con_fvirt, con_epsqs, lw_gas_props, & + subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, & + fhlwr, xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, con_eps,& + con_epsm1, con_fvirt, con_epsqs, minGPpres, & raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, tracer,& - gas_concentrations, errmsg, errflg) + gas_concentrations, errmsg, errflg) ! Inputs integer, intent(in) :: & nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers - nGases, & ! Number of active gases in RRTMGP. nTracers, & ! Number of tracers from model. i_o3 ! Index into tracer array for ozone logical, intent(in) :: & lsswr, & ! Call SW radiation? lslwr ! Call LW radiation - character(len=*),dimension(nGases), intent(in) :: & - active_gases_array ! Character array containing trace gases to include in RRTMGP real(kind_phys), intent(in) :: & + minGPpres, & ! Minimum pressure allowed in RRTMGP fhswr, & ! Frequency of SW radiation call. fhlwr ! Frequency of LW radiation call. real(kind_phys), intent(in) :: & @@ -181,8 +148,6 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, prsi ! Pressure at model-interfaces (Pa) real(kind_phys), dimension(nCol,nLev,nTracers) :: & qgrs ! Tracer concentrations (kg/kg) - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: ! Outputs character(len=*), intent(out) :: & @@ -216,6 +181,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, real(kind_phys) :: es, tem1, tem2 real(kind_phys), dimension(nCol,nLev) :: o3_lay, tem2da, tem2db real(kind_phys), dimension(nCol,nLev, NF_VGAS) :: gas_vmr + character(len=32), dimension(gas_concentrations%get_num_gases()) :: active_gases ! Initialize CCPP error handling variables errmsg = '' @@ -258,7 +224,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, tem2db(1:nCol,2:iSFC) = log(p_lev(1:nCol,2:iSFC)) do iCol = 1, nCol tem2da(iCol,1) = log(p_lay(iCol,1) ) - tem2db(iCol,1) = log(max(lw_gas_props%get_press_min(), p_lev(iCol,1)) ) + tem2db(iCol,1) = log(max(minGPpres, p_lev(iCol,1)) ) tem2db(iCol,iSFC) = log(p_lev(iCol,iSFC) ) enddo ! @@ -277,7 +243,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, do iCol = 1, nCol tem2da(iCol,1) = log(p_lay(iCol,1)) tem2db(iCol,1) = log(p_lev(iCol,1)) - tem2db(iCol,iTOA) = log(max(lw_gas_props%get_press_min(), p_lev(iCol,iTOA)) ) + tem2db(iCol,iTOA) = log(max(minGPpres, p_lev(iCol,iTOA)) ) enddo ! t_lev(1:NCOL,1) = tsfc(1:NCOL) @@ -333,15 +299,22 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, vmr_h2o = merge((q_lay/(1-q_lay))*amdw, 0., q_lay .ne. 1.) vmr_o3 = merge(o3_lay*amdo3, 0., o3_lay .gt. 0.) - ! Initialize and opulate RRTMGP DDT w/ gas-concentrations - call check_error_msg('sw_gas_optics_init',gas_concentrations%init(active_gases_array)) - call check_error_msg('GFS_rrtmgp_pre_run',gas_concentrations%set_vmr(active_gases_array(iStr_o2), gas_vmr(:,:,4))) - call check_error_msg('GFS_rrtmgp_pre_run',gas_concentrations%set_vmr(active_gases_array(iStr_co2), gas_vmr(:,:,1))) - call check_error_msg('GFS_rrtmgp_pre_run',gas_concentrations%set_vmr(active_gases_array(iStr_ch4), gas_vmr(:,:,3))) - call check_error_msg('GFS_rrtmgp_pre_run',gas_concentrations%set_vmr(active_gases_array(iStr_n2o), gas_vmr(:,:,2))) - call check_error_msg('GFS_rrtmgp_pre_run',gas_concentrations%set_vmr(active_gases_array(iStr_h2o), vmr_h2o)) - call check_error_msg('GFS_rrtmgp_pre_run',gas_concentrations%set_vmr(active_gases_array(iStr_o3), vmr_o3)) - + ! Initialize and populate RRTMGP DDT w/ gas-concentrations + active_gases = gas_concentrations%get_gas_names() + do iGas=1,gas_concentrations%get_num_gases() + if (iGas .eq. istr_o2) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_o2', & + gas_concentrations%set_vmr(trim(active_gases(iGas)), gas_vmr(:,:,4))) + if (iGas .eq. istr_co2) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_co2',& + gas_concentrations%set_vmr(trim(active_gases(iGas)), gas_vmr(:,:,1))) + if (iGas .eq. istr_ch4) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_ch4',& + gas_concentrations%set_vmr(trim(active_gases(iGas)), gas_vmr(:,:,3))) + if (iGas .eq. istr_n2o) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_n2o',& + gas_concentrations%set_vmr(trim(active_gases(iGas)), gas_vmr(:,:,2))) + if (iGas .eq. istr_h2o) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_h2o',& + gas_concentrations%set_vmr(trim(active_gases(iGas)), vmr_h2o)) + if (iGas .eq. istr_o3) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_o3', & + gas_concentrations%set_vmr(trim(active_gases(iGas)), vmr_o3)) + enddo ! ####################################################################################### ! Radiation time step (output) (Is this really needed?) (Used by some diagnostics) ! ####################################################################################### @@ -351,7 +324,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nGases, nTracers, i_o3, lsswr, lslwr, ! Setup surface ground temperature and ground/air skin temperature if required. ! ####################################################################################### tsfg(1:NCOL) = tsfc(1:NCOL) - tsfa(1:NCOL) = t_lay(1:NCOL,iSFC)!tsfc(1:NCOL) + tsfa(1:NCOL) = t_lay(1:NCOL,iSFC) end subroutine GFS_rrtmgp_pre_run diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index fd7067ca6..28487974b 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -25,13 +25,12 @@ type = integer intent = in optional = F -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* +[gas_concentrations] + standard_name = Gas_concentrations_for_RRTMGP_suite + long_name = DDT containing gas concentrations for RRTMGP radiation scheme + units = DDT + dimensions = () + type = ty_gas_concs intent = out optional = F [errmsg] @@ -71,15 +70,7 @@ dimensions = () type = integer intent = in - optional = F -[nGases] - standard_name = number_of_active_gases_used_by_RRTMGP - long_name = number of gases available used by RRTMGP (Model%nGases) - units = count - dimensions = () - type = integer - intent = in - optional = F + optional = F [nTracers] standard_name = number_of_tracers long_name = number of tracers @@ -202,15 +193,6 @@ kind = kind_phys intent = in optional = F -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in - optional = F [con_eps] standard_name = ratio_of_dry_air_to_water_vapor_gas_constants long_name = rd/rv @@ -246,13 +228,14 @@ type = real kind = kind_phys intent = in - optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT + optional = F +[minGPpres] + standard_name = minimum_pressure_in_RRTMGP + long_name = minimum pressure allowed in RRTMGP + units = Pa dimensions = () - type = ty_gas_optics_rrtmgp + type = real + kind = kind_phys intent = in optional = F [raddt] diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index f89c2e7e7..14dfb798a 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -6,6 +6,7 @@ module GFS_rrtmgp_sw_post use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate use rrtmgp_aux, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props implicit none public GFS_rrtmgp_sw_post_init,GFS_rrtmgp_sw_post_run,GFS_rrtmgp_sw_post_finalize @@ -26,7 +27,7 @@ end subroutine GFS_rrtmgp_sw_post_init !! subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky_hr, & save_diag, fhswr, coszen, coszdg, t_lay, p_lev, sfc_alb_nir_dir, sfc_alb_nir_dif, & - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, sw_gas_props, fluxswUP_allsky, & + sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, fluxswUP_allsky, & fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, raddt, aerodp, cldsa, mbota, & mtopa, cld_frac, cldtausw, fluxr, & nirbmdi, nirdfdi, visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, & @@ -43,8 +44,6 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky lsswr, & ! Call SW radiation? do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? save_diag ! Output radiation diagnostics? - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! DDT containing SW spectral information real(kind_phys), intent(in) :: & fhswr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_sw_post.meta index 2dc412118..eb7f1600d 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_sw_post.meta @@ -145,14 +145,6 @@ kind = kind_phys intent = in optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [fluxswUP_allsky] standard_name = RRTMGP_sw_flux_profile_upward_allsky long_name = RRTMGP upward shortwave all-sky flux profile diff --git a/physics/GFS_rrtmgp_sw_pre.F90 b/physics/GFS_rrtmgp_sw_pre.F90 index 1268ed26f..13b2e3a00 100644 --- a/physics/GFS_rrtmgp_sw_pre.F90 +++ b/physics/GFS_rrtmgp_sw_pre.F90 @@ -10,6 +10,7 @@ module GFS_rrtmgp_sw_pre cdfnor ! Routine to compute CDF (used to compute percentiles) use mo_gas_optics_rrtmgp, only: & ty_gas_optics_rrtmgp + use rrtmgp_sw_gas_optics, only: sw_gas_props public GFS_rrtmgp_sw_pre_run,GFS_rrtmgp_sw_pre_init,GFS_rrtmgp_sw_pre_finalize contains @@ -29,7 +30,7 @@ end subroutine GFS_rrtmgp_sw_pre_init subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_list, & lndp_prt_list, doSWrad, solhr, lon, coslat, sinlat, snowd, sncovr, snoalb, zorl, & tsfg, tsfa, hprime, alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, lsmask, & - sfc_wts, p_lay, tv_lay, relhum, p_lev, sw_gas_props, nday, idxday, coszen, coszdg, & + sfc_wts, p_lay, tv_lay, relhum, p_lev, nday, idxday, coszen, coszdg, & sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, sfc_alb_dif, & errmsg, errflg) @@ -76,8 +77,6 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_ relhum ! Layer relative-humidity real(kind_phys), dimension(nCol,nLev+1),intent(in) :: & p_lev ! Pressure @ layer interfaces (Pa) - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT: spectral information for SW calculation ! Outputs integer, intent(out) :: & diff --git a/physics/GFS_rrtmgp_sw_pre.meta b/physics/GFS_rrtmgp_sw_pre.meta index 202f1667a..07fdf8957 100644 --- a/physics/GFS_rrtmgp_sw_pre.meta +++ b/physics/GFS_rrtmgp_sw_pre.meta @@ -298,14 +298,6 @@ kind = kind_phys intent = in optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [sfc_alb_nir_dir] standard_name = surface_albedo_nearIR_direct long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir) diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.F90 b/physics/GFS_rrtmgp_thompsonmp_pre.F90 index ea27f3d2b..0d80e8e35 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.F90 +++ b/physics/GFS_rrtmgp_thompsonmp_pre.F90 @@ -14,7 +14,8 @@ module GFS_rrtmgp_thompsonmp_pre make_IceNumber, & make_DropletNumber, & make_RainNumber - use rrtmgp_lw_cloud_optics, only: radliq_lwr, radliq_upr, radice_lwr, radice_upr + use rrtmgp_lw_cloud_optics, only: radliq_lwr => radliq_lwrLW, radliq_upr => radliq_uprLW,& + radice_lwr => radice_lwrLW, radice_upr => radice_uprLW implicit none ! Parameters specific to THOMPSON MP scheme. diff --git a/physics/rrtmgp_lw_aerosol_optics.F90 b/physics/rrtmgp_lw_aerosol_optics.F90 index 2047deaf4..b8a21e85a 100644 --- a/physics/rrtmgp_lw_aerosol_optics.F90 +++ b/physics/rrtmgp_lw_aerosol_optics.F90 @@ -3,6 +3,8 @@ module rrtmgp_lw_aerosol_optics use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_1scl use rrtmgp_aux, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props + use rrtmgp_lw_gas_optics, only: lw_gas_props use module_radiation_aerosols, only: & NF_AESW, & ! Number of optical-fields in SW output (3=tau+g+omega) NF_AELW, & ! Number of optical-fields in LW output (3=tau+g+omega) @@ -30,7 +32,7 @@ end subroutine rrtmgp_lw_aerosol_optics_init !! subroutine rrtmgp_lw_aerosol_optics_run(doLWrad, nCol, nLev, nTracer, nTracerAer,& p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - lw_gas_props, sw_gas_props, aerodp, lw_optical_props_aerosol, errmsg, errflg) + aerodp, lw_optical_props_aerosol, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -55,10 +57,6 @@ subroutine rrtmgp_lw_aerosol_optics_run(doLWrad, nCol, nLev, nTracer, nTracerAer aerfld ! aerosol input concentrations real(kind_phys), dimension(nCol,nLev+1),intent(in) :: & p_lev ! Pressure @ layer-interfaces (Pa) - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT: spectral information for SW calculation - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: spectral information for LW calculation ! Outputs real(kind_phys), dimension(nCol,NSPC1), intent(inout) :: & diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta index 0787d3fc4..4aa1e9e9e 100644 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ b/physics/rrtmgp_lw_aerosol_optics.meta @@ -137,22 +137,6 @@ kind = kind_phys intent = in optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - intent = in - type = ty_gas_optics_rrtmgp - optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [aerodp] standard_name = atmosphere_optical_thickness_due_to_ambient_aerosol_particles long_name = vertical integrated optical depth for various aerosol species diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 341c19fc2..d8aa7e9f0 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -2,9 +2,9 @@ module rrtmgp_lw_cloud_optics use machine, only: kind_phys use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str use mo_rrtmg_lw_cloud_optics, only: rrtmg_lw_cloud_optics + use rrtmgp_lw_gas_optics, only: lw_gas_props use rrtmgp_aux, only: check_error_msg use netcdf @@ -12,16 +12,51 @@ module rrtmgp_lw_cloud_optics public rrtmgp_lw_cloud_optics_init, rrtmgp_lw_cloud_optics_run, rrtmgp_lw_cloud_optics_finalize + type(ty_cloud_optics) :: lw_cloud_props + real(kind_phys) :: & + radliq_facLW, & ! Factor for calculating LUT interpolation indices for liquid + radice_facLW ! Factor for calculating LUT interpolation indices for ice + real(kind_phys), dimension(:,:), allocatable :: & + lut_extliqLW, & ! LUT shortwave liquid extinction coefficient + lut_ssaliqLW, & ! LUT shortwave liquid single scattering albedo + lut_asyliqLW, & ! LUT shortwave liquid asymmetry parameter + band_limsCLDLW ! Beginning and ending wavenumber [cm -1] for each band + real(kind_phys), dimension(:,:,:), allocatable :: & + lut_exticeLW, & ! LUT shortwave ice extinction coefficient + lut_ssaiceLW, & ! LUT shortwave ice single scattering albedo + lut_asyiceLW ! LUT shortwave ice asymmetry parameter + real(kind_phys), dimension(:), allocatable :: & + pade_sizereg_extliqLW, & ! Particle size regime boundaries for shortwave liquid extinction + ! coefficient for Pade interpolation + pade_sizereg_ssaliqLW, & ! Particle size regime boundaries for shortwave liquid single + ! scattering albedo for Pade interpolation + pade_sizereg_asyliqLW, & ! Particle size regime boundaries for shortwave liquid asymmetry + ! parameter for Pade interpolation + pade_sizereg_exticeLW, & ! Particle size regime boundaries for shortwave ice extinction + ! coefficient for Pade interpolation + pade_sizereg_ssaiceLW, & ! Particle size regime boundaries for shortwave ice single + ! scattering albedo for Pade interpolation + pade_sizereg_asyiceLW ! Particle size regime boundaries for shortwave ice asymmetry + ! parameter for Pade interpolation + real(kind_phys), dimension(:,:,:), allocatable :: & + pade_extliqLW, & ! PADE coefficients for shortwave liquid extinction + pade_ssaliqLW, & ! PADE coefficients for shortwave liquid single scattering albedo + pade_asyliqLW ! PADE coefficients for shortwave liquid asymmetry parameter + real(kind_phys), dimension(:,:,:,:), allocatable :: & + pade_exticeLW, & ! PADE coefficients for shortwave ice extinction + pade_ssaiceLW, & ! PADE coefficients for shortwave ice single scattering albedo + pade_asyiceLW ! PADE coefficients for shortwave ice asymmetry parameter + ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics real(kind_phys), parameter :: & absrain = 0.33e-3, & ! Rain drop absorption coefficient \f$(m^{2}/g)\f$ . abssnow0 = 1.5, & ! Snow flake absorption coefficient (micron), fu coeff abssnow1 = 2.34e-3 ! Snow flake absorption coefficient \f$(m^{2}/g)\f$, ncar coef real(kind_phys) :: & - radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation - radliq_upr, & ! Liquid particle size upper bound for LUT interpolation - radice_lwr, & ! Ice particle size upper bound for LUT interpolation - radice_upr ! Ice particle size lower bound for LUT interpolation + radliq_lwrLW, & ! Liquid particle size lower bound for LUT interpolation + radliq_uprLW, & ! Liquid particle size upper bound for LUT interpolation + radice_lwrLW, & ! Ice particle size upper bound for LUT interpolation + radice_uprLW ! Ice particle size lower bound for LUT interpolation contains @@ -31,71 +66,34 @@ module rrtmgp_lw_cloud_optics !! \section arg_table_rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! - subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & - doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_lw_file_clouds, mpicomm, & - mpirank, mpiroot, lw_cloud_props, errmsg, errflg) + subroutine rrtmgp_lw_cloud_optics_init(nCol, nLev, nbndsGPlw, doG_cldoptics, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, & + rrtmgp_lw_file_clouds, mpicomm, mpirank, mpiroot, errmsg, errflg) ! Inputs logical, intent(in) :: & - doG_cldoptics, & ! Use legacy RRTMG cloud-optics? - doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? - doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? + doG_cldoptics, & ! Use legacy RRTMG cloud-optics? + doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? + doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? integer, intent(inout) :: & - nrghice ! Number of ice-roughness categories - integer, intent(in) :: & - mpicomm, & ! MPI communicator - mpirank, & ! Current MPI rank - mpiroot ! Master MPI rank + nrghice ! Number of ice-roughness categories + integer, intent(in) :: & + nbndsGPlw, & ! Number of longwave bands + nCol, & ! Number of horizontal gridpoints + nLev, & ! Number of vertical levels + mpicomm, & ! MPI communicator + mpirank, & ! Current MPI rank + mpiroot ! Master MPI rank character(len=128),intent(in) :: & - rrtmgp_root_dir, & ! RTE-RRTMGP root directory - rrtmgp_lw_file_clouds ! RRTMGP file containing coefficients used to compute clouds optical properties - + rrtmgp_root_dir, & ! RTE-RRTMGP root directory + rrtmgp_lw_file_clouds ! RRTMGP file containing coefficients used to compute clouds optical properties + ! Outputs - type(ty_cloud_optics),intent(out) :: & - lw_cloud_props ! RRTMGP DDT: spectral information for RRTMGP LW radiation scheme character(len=*), intent(out) :: & - errmsg ! Error message + errmsg ! Error message integer, intent(out) :: & - errflg ! Error code + errflg ! Error code - ! Local variables that will be passed to cloud_optics%load() - real(kind_phys) :: & - !radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation - !radliq_upr, & ! Liquid particle size upper bound for LUT interpolation - radliq_fac, & ! Factor for calculating LUT interpolation indices for liquid - !radice_lwr, & ! Ice particle size upper bound for LUT interpolation - !radice_upr, & ! Ice particle size lower bound for LUT interpolation - radice_fac ! Factor for calculating LUT interpolation indices for ice - real(kind_phys), dimension(:,:), allocatable :: & - lut_extliq, & ! LUT shortwave liquid extinction coefficient - lut_ssaliq, & ! LUT shortwave liquid single scattering albedo - lut_asyliq, & ! LUT shortwave liquid asymmetry parameter - band_lims ! Beginning and ending wavenumber [cm -1] for each band - real(kind_phys), dimension(:,:,:), allocatable :: & - lut_extice, & ! LUT shortwave ice extinction coefficient - lut_ssaice, & ! LUT shortwave ice single scattering albedo - lut_asyice ! LUT shortwave ice asymmetry parameter - real(kind_phys), dimension(:), allocatable :: & - pade_sizereg_extliq, & ! Particle size regime boundaries for shortwave liquid extinction - ! coefficient for Pade interpolation - pade_sizereg_ssaliq, & ! Particle size regime boundaries for shortwave liquid single - ! scattering albedo for Pade interpolation - pade_sizereg_asyliq, & ! Particle size regime boundaries for shortwave liquid asymmetry - ! parameter for Pade interpolation - pade_sizereg_extice, & ! Particle size regime boundaries for shortwave ice extinction - ! coefficient for Pade interpolation - pade_sizereg_ssaice, & ! Particle size regime boundaries for shortwave ice single - ! scattering albedo for Pade interpolation - pade_sizereg_asyice ! Particle size regime boundaries for shortwave ice asymmetry - ! parameter for Pade interpolation - real(kind_phys), dimension(:,:,:), allocatable :: & - pade_extliq, & ! PADE coefficients for shortwave liquid extinction - pade_ssaliq, & ! PADE coefficients for shortwave liquid single scattering albedo - pade_asyliq ! PADE coefficients for shortwave liquid asymmetry parameter - real(kind_phys), dimension(:,:,:,:), allocatable :: & - pade_extice, & ! PADE coefficients for shortwave ice extinction - pade_ssaice, & ! PADE coefficients for shortwave ice single scattering albedo - pade_asyice ! PADE coefficients for shortwave ice asymmetry parameter ! Dimensions integer :: & nrghice_fromfile, nBand, nSize_liq, nSize_ice, nSizeReg,& @@ -110,8 +108,13 @@ subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, errmsg = '' errflg = 0 + ! If not using RRTMGP cloud optics, return. if (doG_cldoptics) return + ! + ! Otherwise, using RRTMGP cloud-optics, continue with initialization... + ! + ! Filenames are set in the physics_nml lw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_lw_file_clouds) @@ -141,113 +144,104 @@ subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, status = nf90_inquire_dimension(ncid, dimid, len=npairs) ! Has the number of ice-roughnesses to use been provided from the namelist? - ! If not provided, use default number of ice-roughness categories - if (nrghice .eq. 0) then - nrghice = nrghice_default - else - nrghice = nrghice_fromfile - ! If provided in the namelist, check to ensure that number of ice-roughness categories is feasible. - if (nrghice .gt. nrghice_fromfile) then - errmsg = 'Number of RRTMGP ice-roughness categories requested in namelist file is not allowed. Using default number of categories.' - nrghice = nrghice_default - endif - endif + ! If not, use nrghice from cloud-optics data file. + if (nrghice .eq. 0) nrghice = nrghice_fromfile ! Allocate space for arrays if (doGP_cldoptics_LUT) then - allocate(lut_extliq(nSize_liq, nBand)) - allocate(lut_ssaliq(nSize_liq, nBand)) - allocate(lut_asyliq(nSize_liq, nBand)) - allocate(lut_extice(nSize_ice, nBand, nrghice_fromfile)) - allocate(lut_ssaice(nSize_ice, nBand, nrghice_fromfile)) - allocate(lut_asyice(nSize_ice, nBand, nrghice_fromfile)) + allocate(lut_extliqLW(nSize_liq, nBand)) + allocate(lut_ssaliqLW(nSize_liq, nBand)) + allocate(lut_asyliqLW(nSize_liq, nBand)) + allocate(lut_exticeLW(nSize_ice, nBand, nrghice)) + allocate(lut_ssaiceLW(nSize_ice, nBand, nrghice)) + allocate(lut_asyiceLW(nSize_ice, nBand, nrghice)) endif if (doGP_cldoptics_PADE) then - allocate(pade_extliq(nBand, nSizeReg, nCoeff_ext )) - allocate(pade_ssaliq(nBand, nSizeReg, nCoeff_ssa_g)) - allocate(pade_asyliq(nBand, nSizeReg, nCoeff_ssa_g)) - allocate(pade_extice(nBand, nSizeReg, nCoeff_ext, nrghice_fromfile)) - allocate(pade_ssaice(nBand, nSizeReg, nCoeff_ssa_g, nrghice_fromfile)) - allocate(pade_asyice(nBand, nSizeReg, nCoeff_ssa_g, nrghice_fromfile)) - allocate(pade_sizereg_extliq(nBound)) - allocate(pade_sizereg_ssaliq(nBound)) - allocate(pade_sizereg_asyliq(nBound)) - allocate(pade_sizereg_extice(nBound)) - allocate(pade_sizereg_ssaice(nBound)) - allocate(pade_sizereg_asyice(nBound)) + allocate(pade_extliqLW(nBand, nSizeReg, nCoeff_ext )) + allocate(pade_ssaliqLW(nBand, nSizeReg, nCoeff_ssa_g)) + allocate(pade_asyliqLW(nBand, nSizeReg, nCoeff_ssa_g)) + allocate(pade_exticeLW(nBand, nSizeReg, nCoeff_ext, nrghice)) + allocate(pade_ssaiceLW(nBand, nSizeReg, nCoeff_ssa_g, nrghice)) + allocate(pade_asyiceLW(nBand, nSizeReg, nCoeff_ssa_g, nrghice)) + allocate(pade_sizereg_extliqLW(nBound)) + allocate(pade_sizereg_ssaliqLW(nBound)) + allocate(pade_sizereg_asyliqLW(nBound)) + allocate(pade_sizereg_exticeLW(nBound)) + allocate(pade_sizereg_ssaiceLW(nBound)) + allocate(pade_sizereg_asyiceLW(nBound)) endif - allocate(band_lims(2,nBand)) + allocate(band_limsCLDLW(2,nBand)) ! Read in fields from file if (doGP_cldoptics_LUT) then write (*,*) 'Reading RRTMGP longwave cloud data (LUT) ... ' status = nf90_inq_varid(ncid,'radliq_lwr',varID) - status = nf90_get_var(ncid,varID,radliq_lwr) + status = nf90_get_var(ncid,varID,radliq_lwrLW) status = nf90_inq_varid(ncid,'radliq_upr',varID) - status = nf90_get_var(ncid,varID,radliq_upr) + status = nf90_get_var(ncid,varID,radliq_uprLW) status = nf90_inq_varid(ncid,'radliq_fac',varID) - status = nf90_get_var(ncid,varID,radliq_fac) + status = nf90_get_var(ncid,varID,radliq_facLW) status = nf90_inq_varid(ncid,'radice_lwr',varID) - status = nf90_get_var(ncid,varID,radice_lwr) + status = nf90_get_var(ncid,varID,radice_lwrLW) status = nf90_inq_varid(ncid,'radice_upr',varID) - status = nf90_get_var(ncid,varID,radice_upr) + status = nf90_get_var(ncid,varID,radice_uprLW) status = nf90_inq_varid(ncid,'radice_fac',varID) - status = nf90_get_var(ncid,varID,radice_fac) + status = nf90_get_var(ncid,varID,radice_facLW) status = nf90_inq_varid(ncid,'lut_extliq',varID) - status = nf90_get_var(ncid,varID,lut_extliq) + status = nf90_get_var(ncid,varID,lut_extliqLW) status = nf90_inq_varid(ncid,'lut_ssaliq',varID) - status = nf90_get_var(ncid,varID,lut_ssaliq) + status = nf90_get_var(ncid,varID,lut_ssaliqLW) status = nf90_inq_varid(ncid,'lut_asyliq',varID) - status = nf90_get_var(ncid,varID,lut_asyliq) + status = nf90_get_var(ncid,varID,lut_asyliqLW) status = nf90_inq_varid(ncid,'lut_extice',varID) - status = nf90_get_var(ncid,varID,lut_extice) + status = nf90_get_var(ncid,varID,lut_exticeLW) status = nf90_inq_varid(ncid,'lut_ssaice',varID) - status = nf90_get_var(ncid,varID,lut_ssaice) + status = nf90_get_var(ncid,varID,lut_ssaiceLW) status = nf90_inq_varid(ncid,'lut_asyice',varID) - status = nf90_get_var(ncid,varID,lut_asyice) + status = nf90_get_var(ncid,varID,lut_asyiceLW) status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varID) - status = nf90_get_var(ncid,varID,band_lims) + status = nf90_get_var(ncid,varID,band_limsCLDLW) endif if (doGP_cldoptics_PADE) then write (*,*) 'Reading RRTMGP longwave cloud data (PADE) ... ' status = nf90_inq_varid(ncid,'radliq_lwr',varID) - status = nf90_get_var(ncid,varID,radliq_lwr) + status = nf90_get_var(ncid,varID,radliq_lwrLW) status = nf90_inq_varid(ncid,'radliq_upr',varID) - status = nf90_get_var(ncid,varID,radliq_upr) + status = nf90_get_var(ncid,varID,radliq_uprLW) status = nf90_inq_varid(ncid,'radliq_fac',varID) - status = nf90_get_var(ncid,varID,radliq_fac) + status = nf90_get_var(ncid,varID,radliq_facLW) status = nf90_inq_varid(ncid,'radice_lwr',varID) - status = nf90_get_var(ncid,varID,radice_lwr) + status = nf90_get_var(ncid,varID,radice_lwrLW) status = nf90_inq_varid(ncid,'radice_upr',varID) - status = nf90_get_var(ncid,varID,radice_upr) + status = nf90_get_var(ncid,varID,radice_uprLW) status = nf90_inq_varid(ncid,'radice_fac',varID) - status = nf90_get_var(ncid,varID,radice_fac) + status = nf90_get_var(ncid,varID,radice_facLW) status = nf90_inq_varid(ncid,'pade_extliq',varID) - status = nf90_get_var(ncid,varID,pade_extliq) + status = nf90_get_var(ncid,varID,pade_extliqLW) status = nf90_inq_varid(ncid,'pade_ssaliq',varID) - status = nf90_get_var(ncid,varID,pade_ssaliq) + status = nf90_get_var(ncid,varID,pade_ssaliqLW) status = nf90_inq_varid(ncid,'pade_asyliq',varID) - status = nf90_get_var(ncid,varID,pade_asyliq) + status = nf90_get_var(ncid,varID,pade_asyliqLW) status = nf90_inq_varid(ncid,'pade_extice',varID) - status = nf90_get_var(ncid,varID,pade_extice) + status = nf90_get_var(ncid,varID,pade_exticeLW) status = nf90_inq_varid(ncid,'pade_ssaice',varID) - status = nf90_get_var(ncid,varID,pade_ssaice) + status = nf90_get_var(ncid,varID,pade_ssaiceLW) status = nf90_inq_varid(ncid,'pade_asyice',varID) - status = nf90_get_var(ncid,varID,pade_asyice) + status = nf90_get_var(ncid,varID,pade_asyiceLW) status = nf90_inq_varid(ncid,'pade_sizreg_extliq',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_extliq) + status = nf90_get_var(ncid,varID,pade_sizereg_extliqLW) status = nf90_inq_varid(ncid,'pade_sizreg_ssaliq',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_ssaliq) + status = nf90_get_var(ncid,varID,pade_sizereg_ssaliqLW) status = nf90_inq_varid(ncid,'pade_sizreg_asyliq',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_asyliq) + status = nf90_get_var(ncid,varID,pade_sizereg_asyliqLW) status = nf90_inq_varid(ncid,'pade_sizreg_extice',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_extice) + status = nf90_get_var(ncid,varID,pade_sizereg_exticeLW) status = nf90_inq_varid(ncid,'pade_sizreg_ssaice',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_ssaice) + status = nf90_get_var(ncid,varID,pade_sizereg_ssaiceLW) status = nf90_inq_varid(ncid,'pade_sizreg_asyice',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_asyice) + status = nf90_get_var(ncid,varID,pade_sizereg_asyiceLW) status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varID) - status = nf90_get_var(ncid,varID,band_lims) + status = nf90_get_var(ncid,varID,band_limsCLDLW) endif ! Close file @@ -256,17 +250,23 @@ subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, ! Load tables data for RRTMGP cloud-optics if (doGP_cldoptics_LUT) then - call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_lims, & - radliq_lwr, radliq_upr, radliq_fac, radice_lwr, radice_upr, radice_fac, & - lut_extliq, lut_ssaliq, lut_asyliq, lut_extice, lut_ssaice, lut_asyice)) +!$omp critical (load_lw_cloud_props_LUTs) + call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_limsCLDLW, & + radliq_lwrLW, radliq_uprLW, radliq_facLW, radice_lwrLW, radice_uprLW, radice_facLW, & + lut_extliqLW, lut_ssaliqLW, lut_asyliqLW, lut_exticeLW, lut_ssaiceLW, lut_asyiceLW)) +!$omp end critical (load_lw_cloud_props_LUTs) endif if (doGP_cldoptics_PADE) then - call check_error_msg('lw_cloud_optics_init', lw_cloud_props%load(band_lims, & - pade_extliq, pade_ssaliq, pade_asyliq, pade_extice, pade_ssaice, pade_asyice,& - pade_sizereg_extliq, pade_sizereg_ssaliq, pade_sizereg_asyliq, & - pade_sizereg_extice, pade_sizereg_ssaice, pade_sizereg_asyice)) +!$omp critical (load_lw_cloud_props_PADE_approx) + call check_error_msg('lw_cloud_optics_init', lw_cloud_props%load(band_limsCLDLW, & + pade_extliqLW, pade_ssaliqLW, pade_asyliqLW, pade_exticeLW, pade_ssaiceLW, pade_asyiceLW,& + pade_sizereg_extliqLW, pade_sizereg_ssaliqLW, pade_sizereg_asyliqLW, & + pade_sizereg_exticeLW, pade_sizereg_ssaiceLW, pade_sizereg_asyiceLW)) +!$omp endcritical (load_lw_cloud_props_PADE_approx) endif +!$omp critical (load_lw_cloud_props_nrghice) call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(nrghice)) +!$omp end critical (load_lw_cloud_props_nrghice) end subroutine rrtmgp_lw_cloud_optics_init @@ -277,9 +277,9 @@ end subroutine rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, nCol, nLev, nrghice, p_lay, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, nCol, nLev, nbndsGPlw, p_lay, & cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, lw_cloud_props, lw_gas_props, lon, lat, cldtaulw, & + cld_rerain, precip_frac, lon, lat, cldtaulw, & lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) ! Inputs @@ -290,9 +290,9 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw doGP_cldoptics_LUT, & ! Use RRTMGP cloud-optics: LUTs? doGP_lwscat ! Include scattering in LW cloud-optics? integer, intent(in) :: & + nbndsGPlw, & ! Number of longwave bands nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels - nrghice, & ! Number of ice-roughness categories icliq_lw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) icice_lw ! Choice of treatment of ice cloud optical properties (RRTMG legacy) real(kind_phys), dimension(nCol), intent(in) :: & @@ -310,17 +310,13 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius precip_frac ! Precipitation fraction by layer. - type(ty_cloud_optics),intent(in) :: & - lw_cloud_props ! RRTMGP DDT: spectral information for RRTMGP LW radiation scheme - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: spectral information for RRTMGP LW radiation scheme ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error flag - type(ty_optical_props_2str),intent(inout) :: & + type(ty_optical_props_2str),intent(out) :: & lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) real(kind_phys), dimension(ncol,nLev), intent(inout) :: & @@ -328,7 +324,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw ! Local variables real(kind_phys) :: tau_rain, tau_snow - real(kind_phys), dimension(ncol,nLev,lw_gas_props%get_nband()) :: & + real(kind_phys), dimension(ncol,nLev,nbndsGPlw) :: & tau_cld, tau_precip integer :: iCol, iLay, iBand @@ -342,23 +338,15 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw if (.not. doLWrad) return - ! Allocate space for RRTMGP DDTs containing cloud radiative properties - ! Cloud optics [nCol,nLev,nBands] - call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_cloudsByBand%alloc_2str(& - ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) - lw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys - lw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys - lw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys - - ! Precipitation optics [nCol,nLev,nBands] - call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_precipByBand%alloc_2str(& - ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) - lw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - lw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys - lw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - ! Compute cloud-optics for RTE. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_cloudsByBand%alloc_2str(& + ncol, nLev, lw_cloud_props%get_band_lims_wavenumber())) + lw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys + call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_precipByBand%alloc_2str(& + ncol, nLev, lw_cloud_props%get_band_lims_wavenumber())) + lw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys + ! i) RRTMGP cloud-optics. call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_cloud_props%cloud_optics(& cld_lwp, & ! IN - Cloud liquid water path (g/m2) @@ -380,7 +368,7 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw else tau_snow = 0.0 endif - do iBand=1,lw_gas_props%get_nband() + do iBand=1,nbndsGPlw lw_optical_props_precipByBand%tau(iCol,iLay,iBand) = tau_rain + tau_snow enddo endif @@ -388,11 +376,17 @@ subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw enddo endif if (doG_cldoptics) then + call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_cloudsByBand%alloc_2str(& + ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys + call check_error_msg('rrtmgp_lw_cloud_optics_run',lw_optical_props_precipByBand%alloc_2str(& + ncol, nLev, lw_gas_props%get_band_lims_wavenumber())) + lw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys ! ii) RRTMG cloud-optics. if (any(cld_frac .gt. 0)) then - call rrtmg_lw_cloud_optics(ncol, nLev, lw_gas_props%get_nband(), cld_lwp, & - cld_reliq, cld_iwp, cld_reice, cld_rwp, cld_rerain, cld_swp, cld_resnow, & - cld_frac, icliq_lw, icice_lw, tau_cld, tau_precip) + call rrtmg_lw_cloud_optics(ncol, nLev, nbndsGPlw, cld_lwp, cld_reliq, cld_iwp,& + cld_reice, cld_rwp, cld_rerain, cld_swp, cld_resnow, cld_frac, icliq_lw, & + icice_lw, tau_cld, tau_precip) lw_optical_props_cloudsByBand%tau = tau_cld lw_optical_props_precipByBand%tau = tau_precip endif diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index c57e70a33..80cf60bf5 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -7,6 +7,30 @@ [ccpp-arg-table] name = rrtmgp_lw_cloud_optics_init type = scheme +[nbndsGPlw] + standard_name = number_of_lw_bands_rrtmgp + long_name = number of lw bands used in RRTMGP + units = count + dimensions = () + type = integer + intent = in + optional = F +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[nLev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F [doG_cldoptics] standard_name = flag_to_calc_lw_cld_optics_using_RRTMG long_name = logical flag to control cloud optics scheme. @@ -98,14 +122,6 @@ type = integer intent = out optional = F -[lw_cloud_props] - standard_name = coefficients_for_lw_cloud_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - type = ty_cloud_optics - intent = out - optional = F ######################################################################## [ccpp-arg-table] @@ -183,14 +199,6 @@ type = integer intent = in optional = F -[nrghice] - standard_name = number_of_rrtmgp_ice_roughness - long_name = number of ice-roughness categories in RRTMGP calculation - units = count - dimensions = () - type = integer - intent = in - optional = F [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction @@ -281,21 +289,13 @@ kind = kind_phys intent = in optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - intent = in - type = ty_gas_optics_rrtmgp - optional = F -[lw_cloud_props] - standard_name = coefficients_for_lw_cloud_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () +[nbndsGPlw] + standard_name = number_of_lw_bands_rrtmgp + long_name = number of lw bands used in RRTMGP + units = count + dimensions = () + type = integer intent = in - type = ty_cloud_optics optional = F [lon] standard_name = longitude diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index 902a4e20f..8274dbd13 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -5,6 +5,7 @@ module rrtmgp_lw_cloud_sampling use rrtmgp_sampling, only: sampled_mask, draw_samples use mersenne_twister, only: random_setseed, random_number, random_stat use rrtmgp_aux, only: check_error_msg + use rrtmgp_lw_gas_optics, only: lw_gas_props use netcdf implicit none @@ -17,10 +18,7 @@ module rrtmgp_lw_cloud_sampling !! \section arg_table_rrtmgp_lw_cloud_sampling_init !! \htmlinclude rrtmgp_lw_cloud_sampling_init.html !! - subroutine rrtmgp_lw_cloud_sampling_init(lw_gas_props, ipsdlw0, errmsg, errflg) - ! Inputs - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: K-distribution data + subroutine rrtmgp_lw_cloud_sampling_init(ipsdlw0, errmsg, errflg) ! Outputs integer, intent(out) :: & ipsdlw0 ! Initial permutation seed for McICA @@ -46,7 +44,7 @@ end subroutine rrtmgp_lw_cloud_sampling_init !! subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, iovr, & iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, & - cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, lw_gas_props, & + cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, & doGP_lwscat, lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, & lw_optical_props_clouds, lw_optical_props_precip, errmsg, errflg) @@ -77,8 +75,6 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, real(kind_phys), dimension(ncol,nLev), intent(in) :: & cloud_overlap_param, & ! Cloud overlap parameter precip_overlap_param ! Precipitation overlap parameter - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: K-distribution data type(ty_optical_props_2str),intent(in) :: & lw_optical_props_cloudsByBand, & ! RRTMGP DDT: Longwave optical properties in each band (clouds) lw_optical_props_precipByBand ! RRTMGP DDT: Longwave optical properties in each band (precipitation) diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index 2438f715c..4e54d14b0 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -7,14 +7,6 @@ [ccpp-arg-table] name = rrtmgp_lw_cloud_sampling_init type = scheme -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [ipsdlw0] standard_name = initial_permutation_seed_lw long_name = initial seed for McICA LW @@ -192,14 +184,6 @@ type = real kind = kind_phys intent = in - optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in optional = F [lw_optical_props_cloudsByBand] standard_name = longwave_optical_properties_for_cloudy_atmosphere_by_band diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index f8a01b982..df2021864 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -8,91 +8,87 @@ module rrtmgp_lw_gas_optics use mo_compute_bc, only: compute_bc use rrtmgp_aux, only: check_error_msg use netcdf - implicit none + type(ty_gas_optics_rrtmgp) :: lw_gas_props + integer, dimension(:), allocatable :: & + kminor_start_lowerLW, & ! Starting index in the [1, nContributors] vector for a contributor + ! given by \"minor_gases_lower\" (lower atmosphere) + kminor_start_upperLW ! Starting index in the [1, nContributors] vector for a contributor + ! given by \"minor_gases_upper\" (upper atmosphere) + integer, dimension(:,:), allocatable :: & + band2gptLW, & ! Beginning and ending gpoint for each band + minor_limits_gpt_lowerLW, & ! Beginning and ending gpoint for each minor interval in lower atmosphere + minor_limits_gpt_upperLW ! Beginning and ending gpoint for each minor interval in upper atmosphere + integer, dimension(:,:,:), allocatable :: & + key_speciesLW ! Key species pair for each band + real(kind_phys) :: & + press_ref_tropLW, & ! Reference pressure separating the lower and upper atmosphere [Pa] + temp_ref_pLW, & ! Standard spectroscopic reference pressure [Pa] + temp_ref_tLW ! Standard spectroscopic reference temperature [K] + real(kind_phys), dimension(:), allocatable :: & + press_refLW, & ! Pressures for reference atmosphere; press_ref(# reference layers) [Pa] + temp_refLW ! Temperatures for reference atmosphere; temp_ref(# reference layers) [K] + real(kind_phys), dimension(:,:), allocatable :: & + band_limsLW, & ! Beginning and ending wavenumber [cm -1] for each band + totplnkLW, & ! Integrated Planck function by band + optimal_angle_fitLW + real(kind_phys), dimension(:,:,:), allocatable :: & + vmr_refLW, & ! volume mixing ratios for reference atmospherer + kminor_lowerLW, & ! (transformed from [nTemp x nEta x nGpt x nAbsorbers] array to + ! [nTemp x nEta x nContributors] array) + kminor_upperLW, & ! (transformed from [nTemp x nEta x nGpt x nAbsorbers] array to + ! [nTemp x nEta x nContributors] array) + rayl_lowerLW, & ! Not used in LW, rather allocated(rayl_lower) is used + rayl_upperLW ! Not used in LW, rather allocated(rayl_upper) is used + real(kind_phys), dimension(:,:,:,:), allocatable :: & + kmajorLW, & ! Stored absorption coefficients due to major absorbing gases + planck_fracLW ! Planck fractions + character(len=32), dimension(:), allocatable :: & + gas_namesLW, & ! Names of absorbing gases + gas_minorLW, & ! Name of absorbing minor gas + identifier_minorLW, & ! Unique string identifying minor gas + minor_gases_lowerLW, & ! Names of minor absorbing gases in lower atmosphere + minor_gases_upperLW, & ! Names of minor absorbing gases in upper atmosphere + scaling_gas_lowerLW, & ! Absorption also depends on the concentration of this gas + scaling_gas_upperLW ! Absorption also depends on the concentration of this gas + logical(wl), dimension(:), allocatable :: & + minor_scales_with_density_lowerLW, & ! Density scaling is applied to minor absorption coefficients + minor_scales_with_density_upperLW, & ! Density scaling is applied to minor absorption coefficients + scale_by_complement_lowerLW, & ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) + scale_by_complement_upperLW ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) + contains ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_gas_optics_init + ! SUBROUTINE rrtmgp_lw_gas_optics_init ! ######################################################################################### !! \section arg_table_rrtmgp_lw_gas_optics_init !! \htmlinclude rrtmgp_lw_gas_optics_init.html !! - subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp_nGases, & - active_gases_array, mpicomm, mpirank, mpiroot, lw_gas_props, errmsg, errflg) + subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_concentrations,& + nCol, nLev, mpicomm, mpirank, mpiroot, minGPpres, errmsg, errflg) ! Inputs + type(ty_gas_concs), intent(in) :: & + gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties - integer, intent(in) :: & - rrtmgp_nGases ! Number of trace gases active in RRTMGP - character(len=*),dimension(rrtmgp_nGases), intent(in) :: & - active_gases_array ! Character array containing trace gases to include in RRTMGP integer,intent(in) :: & + nCol, & ! Number of horizontal points + nLev, & ! Number of vertical levels mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank ! Outputs character(len=*), intent(out) :: & - errmsg ! CCPP error message + errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error code - type(ty_gas_optics_rrtmgp),intent(out) :: & - lw_gas_props ! RRTMGP DDT: longwave spectral information - - ! Variables that will be passed to gas_optics%load() - type(ty_gas_concs) :: & - gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) - integer, dimension(:), allocatable :: & - kminor_start_lower, & ! Starting index in the [1, nContributors] vector for a contributor - ! given by \"minor_gases_lower\" (lower atmosphere) - kminor_start_upper ! Starting index in the [1, nContributors] vector for a contributor - ! given by \"minor_gases_upper\" (upper atmosphere) - integer, dimension(:,:), allocatable :: & - band2gpt, & ! Beginning and ending gpoint for each band - minor_limits_gpt_lower, & ! Beginning and ending gpoint for each minor interval in lower atmosphere - minor_limits_gpt_upper ! Beginning and ending gpoint for each minor interval in upper atmosphere - integer, dimension(:,:,:), allocatable :: & - key_species ! Key species pair for each band - real(kind_phys) :: & - press_ref_trop, & ! Reference pressure separating the lower and upper atmosphere [Pa] - temp_ref_p, & ! Standard spectroscopic reference pressure [Pa] - temp_ref_t ! Standard spectroscopic reference temperature [K] - real(kind_phys), dimension(:), allocatable :: & - press_ref, & ! Pressures for reference atmosphere; press_ref(# reference layers) [Pa] - temp_ref ! Temperatures for reference atmosphere; temp_ref(# reference layers) [K] - real(kind_phys), dimension(:,:), allocatable :: & - band_lims, & ! Beginning and ending wavenumber [cm -1] for each band - totplnk, & ! Integrated Planck function by band - optimal_angle_fit - real(kind_phys), dimension(:,:,:), allocatable :: & - vmr_ref, & ! volume mixing ratios for reference atmosphere - kminor_lower, & ! (transformed from [nTemp x nEta x nGpt x nAbsorbers] array to - ! [nTemp x nEta x nContributors] array) - kminor_upper, & ! (transformed from [nTemp x nEta x nGpt x nAbsorbers] array to - ! [nTemp x nEta x nContributors] array) - rayl_lower, & ! Not used in LW, rather allocated(rayl_lower) is used - rayl_upper ! Not used in LW, rather allocated(rayl_upper) is used - real(kind_phys), dimension(:,:,:,:), allocatable :: & - kmajor, & ! Stored absorption coefficients due to major absorbing gases - planck_frac ! Planck fractions - character(len=32), dimension(:), allocatable :: & - gas_names, & ! Names of absorbing gases - gas_minor, & ! Name of absorbing minor gas - identifier_minor, & ! Unique string identifying minor gas - minor_gases_lower, & ! Names of minor absorbing gases in lower atmosphere - minor_gases_upper, & ! Names of minor absorbing gases in upper atmosphere - scaling_gas_lower, & ! Absorption also depends on the concentration of this gas - scaling_gas_upper ! Absorption also depends on the concentration of this gas - logical(wl), dimension(:), allocatable :: & - minor_scales_with_density_lower, & ! Density scaling is applied to minor absorption coefficients - minor_scales_with_density_upper, & ! Density scaling is applied to minor absorption coefficients - scale_by_complement_lower, & ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) - scale_by_complement_upper ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) - + errflg ! CCPP error code + real(kind_phys), intent(out) :: & + minGPpres ! Minimum pressure allowed by RRTMGP. ! Dimensions integer :: & ntemps, npress, ngpts, nabsorbers, nextrabsorbers, nminorabsorbers,& @@ -101,7 +97,7 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp ncontributors_lower, ncontributors_upper,nfit_coeffs ! Local variables - integer :: ncid, dimID, varID, status, iGas, ierr + integer :: ncid, dimID, varID, status, iGas, ierr, ii integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4, & temp_log_array1, temp_log_array2, temp_log_array3, temp_log_array4 character(len=264) :: lw_gas_props_file @@ -153,125 +149,137 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp status = nf90_inquire_dimension(ncid, dimid, len = ninternalSourcetemps) ! Allocate space for arrays - allocate(gas_names(nabsorbers)) - allocate(scaling_gas_lower(nminor_absorber_intervals_lower)) - allocate(scaling_gas_upper(nminor_absorber_intervals_upper)) - allocate(gas_minor(nminorabsorbers)) - allocate(identifier_minor(nminorabsorbers)) - allocate(minor_gases_lower(nminor_absorber_intervals_lower)) - allocate(minor_gases_upper(nminor_absorber_intervals_upper)) - allocate(minor_limits_gpt_lower(npairs,nminor_absorber_intervals_lower)) - allocate(minor_limits_gpt_upper(npairs,nminor_absorber_intervals_upper)) - allocate(band2gpt(2,nbnds)) - allocate(key_species(2,nlayers,nbnds)) - allocate(band_lims(2,nbnds)) - allocate(press_ref(npress)) - allocate(temp_ref(ntemps)) - allocate(vmr_ref(nlayers, nextrabsorbers, ntemps)) - allocate(kminor_lower(ncontributors_lower, nmixingfracs, ntemps)) - allocate(kmajor(ngpts, nmixingfracs, npress+1, ntemps)) - allocate(kminor_start_lower(nminor_absorber_intervals_lower)) - allocate(kminor_upper(ncontributors_upper, nmixingfracs, ntemps)) - allocate(kminor_start_upper(nminor_absorber_intervals_upper)) - allocate(optimal_angle_fit(nfit_coeffs,nbnds)) - allocate(minor_scales_with_density_lower(nminor_absorber_intervals_lower)) - allocate(minor_scales_with_density_upper(nminor_absorber_intervals_upper)) - allocate(scale_by_complement_lower(nminor_absorber_intervals_lower)) - allocate(scale_by_complement_upper(nminor_absorber_intervals_upper)) + allocate(gas_namesLW(nabsorbers)) + allocate(scaling_gas_lowerLW(nminor_absorber_intervals_lower)) + allocate(scaling_gas_upperLW(nminor_absorber_intervals_upper)) + allocate(gas_minorLW(nminorabsorbers)) + allocate(identifier_minorLW(nminorabsorbers)) + allocate(minor_gases_lowerLW(nminor_absorber_intervals_lower)) + allocate(minor_gases_upperLW(nminor_absorber_intervals_upper)) + allocate(minor_limits_gpt_lowerLW(npairs,nminor_absorber_intervals_lower)) + allocate(minor_limits_gpt_upperLW(npairs,nminor_absorber_intervals_upper)) + allocate(band2gptLW(2,nbnds)) + allocate(key_speciesLW(2,nlayers,nbnds)) + allocate(band_limsLW(2,nbnds)) + allocate(press_refLW(npress)) + allocate(temp_refLW(ntemps)) + allocate(vmr_refLW(nlayers, nextrabsorbers, ntemps)) + allocate(kminor_lowerLW(ncontributors_lower, nmixingfracs, ntemps)) + allocate(kmajorLW(ngpts, nmixingfracs, npress+1, ntemps)) + allocate(kminor_start_lowerLW(nminor_absorber_intervals_lower)) + allocate(kminor_upperLW(ncontributors_upper, nmixingfracs, ntemps)) + allocate(kminor_start_upperLW(nminor_absorber_intervals_upper)) + allocate(optimal_angle_fitLW(nfit_coeffs,nbnds)) + allocate(minor_scales_with_density_lowerLW(nminor_absorber_intervals_lower)) + allocate(minor_scales_with_density_upperLW(nminor_absorber_intervals_upper)) + allocate(scale_by_complement_lowerLW(nminor_absorber_intervals_lower)) + allocate(scale_by_complement_upperLW(nminor_absorber_intervals_upper)) allocate(temp1(nminor_absorber_intervals_lower)) allocate(temp2(nminor_absorber_intervals_upper)) allocate(temp3(nminor_absorber_intervals_lower)) allocate(temp4(nminor_absorber_intervals_upper)) - allocate(totplnk(ninternalSourcetemps, nbnds)) - allocate(planck_frac(ngpts, nmixingfracs, npress+1, ntemps)) + allocate(totplnkLW(ninternalSourcetemps, nbnds)) + allocate(planck_fracLW(ngpts, nmixingfracs, npress+1, ntemps)) ! Read in fields from file if (mpirank==mpiroot) write (*,*) 'Reading RRTMGP longwave k-distribution data ... ' status = nf90_inq_varid(ncid, 'gas_names', varID) - status = nf90_get_var( ncid, varID, gas_names) + status = nf90_get_var( ncid, varID, gas_namesLW) status = nf90_inq_varid(ncid, 'scaling_gas_lower', varID) - status = nf90_get_var( ncid, varID, scaling_gas_lower) + status = nf90_get_var( ncid, varID, scaling_gas_lowerLW) status = nf90_inq_varid(ncid, 'scaling_gas_upper', varID) - status = nf90_get_var( ncid, varID, scaling_gas_upper) + status = nf90_get_var( ncid, varID, scaling_gas_upperLW) status = nf90_inq_varid(ncid, 'gas_minor', varID) - status = nf90_get_var( ncid, varID, gas_minor) + status = nf90_get_var( ncid, varID, gas_minorLW) status = nf90_inq_varid(ncid, 'identifier_minor', varID) - status = nf90_get_var( ncid, varID, identifier_minor) + status = nf90_get_var( ncid, varID, identifier_minorLW) status = nf90_inq_varid(ncid, 'minor_gases_lower', varID) - status = nf90_get_var( ncid, varID, minor_gases_lower) + status = nf90_get_var( ncid, varID, minor_gases_lowerLW) status = nf90_inq_varid(ncid, 'minor_gases_upper', varID) - status = nf90_get_var( ncid, varID, minor_gases_upper) + status = nf90_get_var( ncid, varID, minor_gases_upperLW) status = nf90_inq_varid(ncid, 'minor_limits_gpt_lower', varID) - status = nf90_get_var( ncid, varID, minor_limits_gpt_lower) + status = nf90_get_var( ncid, varID, minor_limits_gpt_lowerLW) status = nf90_inq_varid(ncid, 'minor_limits_gpt_upper', varID) - status = nf90_get_var( ncid, varID, minor_limits_gpt_upper) + status = nf90_get_var( ncid, varID, minor_limits_gpt_upperLW) status = nf90_inq_varid(ncid, 'bnd_limits_gpt', varID) - status = nf90_get_var( ncid, varID, band2gpt) + status = nf90_get_var( ncid, varID, band2gptLW) status = nf90_inq_varid(ncid, 'key_species', varID) - status = nf90_get_var( ncid, varID, key_species) + status = nf90_get_var( ncid, varID, key_speciesLW) status = nf90_inq_varid(ncid, 'bnd_limits_wavenumber', varID) - status = nf90_get_var( ncid, varID, band_lims) + status = nf90_get_var( ncid, varID, band_limsLW) status = nf90_inq_varid(ncid, 'press_ref', varID) - status = nf90_get_var( ncid, varID, press_ref) + status = nf90_get_var( ncid, varID, press_refLW) status = nf90_inq_varid(ncid, 'temp_ref', varID) - status = nf90_get_var( ncid, varID, temp_ref) + status = nf90_get_var( ncid, varID, temp_refLW) status = nf90_inq_varid(ncid, 'absorption_coefficient_ref_P', varID) - status = nf90_get_var( ncid, varID, temp_ref_p) + status = nf90_get_var( ncid, varID, temp_ref_pLW) status = nf90_inq_varid(ncid, 'absorption_coefficient_ref_T', varID) - status = nf90_get_var( ncid, varID, temp_ref_t) + status = nf90_get_var( ncid, varID, temp_ref_tLW) status = nf90_inq_varid(ncid, 'press_ref_trop', varID) - status = nf90_get_var( ncid, varID, press_ref_trop) + status = nf90_get_var( ncid, varID, press_ref_tropLW) status = nf90_inq_varid(ncid, 'kminor_lower', varID) - status = nf90_get_var( ncid, varID, kminor_lower) + status = nf90_get_var( ncid, varID, kminor_lowerLW) status = nf90_inq_varid(ncid, 'kminor_upper', varID) - status = nf90_get_var( ncid, varID, kminor_upper) + status = nf90_get_var( ncid, varID, kminor_upperLW) status = nf90_inq_varid(ncid, 'vmr_ref', varID) - status = nf90_get_var( ncid, varID, vmr_ref) + status = nf90_get_var( ncid, varID, vmr_refLW) status = nf90_inq_varid(ncid, 'optimal_angle_fit',varID) - status = nf90_get_var( ncid, varID, optimal_angle_fit) + status = nf90_get_var( ncid, varID, optimal_angle_fitLW) status = nf90_inq_varid(ncid, 'kmajor', varID) - status = nf90_get_var( ncid, varID, kmajor) + status = nf90_get_var( ncid, varID, kmajorLW) status = nf90_inq_varid(ncid, 'kminor_start_lower', varID) - status = nf90_get_var( ncid, varID, kminor_start_lower) + status = nf90_get_var( ncid, varID, kminor_start_lowerLW) status = nf90_inq_varid(ncid, 'kminor_start_upper', varID) - status = nf90_get_var( ncid, varID, kminor_start_upper) + status = nf90_get_var( ncid, varID, kminor_start_upperLW) status = nf90_inq_varid(ncid, 'totplnk', varID) - status = nf90_get_var( ncid, varID, totplnk) + status = nf90_get_var( ncid, varID, totplnkLW) status = nf90_inq_varid(ncid, 'plank_fraction', varID) - status = nf90_get_var( ncid, varID, planck_frac) - + status = nf90_get_var( ncid, varID, planck_fracLW) + ! Logical fields are read in as integers and then converted to logicals. - status = nf90_inq_varid(ncid, 'minor_scales_with_density_lower', varID) + status = nf90_inq_varid(ncid,'minor_scales_with_density_lower', varID) status = nf90_get_var( ncid, varID,temp1) - minor_scales_with_density_lower(:) = .false. - where(temp1 .eq. 1) minor_scales_with_density_lower(:) = .true. - status = nf90_inq_varid(ncid, 'minor_scales_with_density_upper', varID) + status = nf90_inq_varid(ncid,'minor_scales_with_density_upper', varID) status = nf90_get_var( ncid, varID,temp2) - minor_scales_with_density_upper(:) = .false. - where(temp2 .eq. 1) minor_scales_with_density_upper(:) = .true. - status = nf90_inq_varid(ncid, 'scale_by_complement_lower', varID) + status = nf90_inq_varid(ncid,'scale_by_complement_lower', varID) status = nf90_get_var( ncid, varID,temp3) - scale_by_complement_lower(:) = .false. - where(temp3 .eq. 1) scale_by_complement_lower(:) = .true. - status = nf90_inq_varid(ncid, 'scale_by_complement_upper', varID) + status = nf90_inq_varid(ncid,'scale_by_complement_upper', varID) status = nf90_get_var( ncid, varID,temp4) - scale_by_complement_upper(:) = .false. - where(temp4 .eq. 1) scale_by_complement_upper(:) = .true. - - ! Close file - status = nf90_close(ncid) + status = nf90_close(ncid) + + do ii=1,nminor_absorber_intervals_lower + if (temp1(ii) .eq. 0) minor_scales_with_density_lowerLW(ii) = .false. + if (temp1(ii) .eq. 1) minor_scales_with_density_lowerLW(ii) = .true. + if (temp3(ii) .eq. 0) scale_by_complement_lowerLW(ii) = .false. + if (temp3(ii) .eq. 1) scale_by_complement_lowerLW(ii) = .true. + enddo + do ii=1,nminor_absorber_intervals_upper + if (temp2(ii) .eq. 0) minor_scales_with_density_upperLW(ii) = .false. + if (temp2(ii) .eq. 1) minor_scales_with_density_upperLW(ii) = .true. + if (temp4(ii) .eq. 0) scale_by_complement_upperLW(ii) = .false. + if (temp4(ii) .eq. 1) scale_by_complement_upperLW(ii) = .true. + enddo ! endif - ! Initialize gas concentrations and gas optics class - call check_error_msg('lw_gas_optics_init',gas_concentrations%init(active_gases_array)) - call check_error_msg('lw_gas_optics_init',lw_gas_props%load(gas_concentrations, gas_names, & - key_species, band2gpt, band_lims, press_ref, press_ref_trop, temp_ref, temp_ref_p, & - temp_ref_t, vmr_ref, kmajor, kminor_lower, kminor_upper, gas_minor, identifier_minor, & - minor_gases_lower, minor_gases_upper, minor_limits_gpt_lower, minor_limits_gpt_upper, & - minor_scales_with_density_lower, minor_scales_with_density_upper, scaling_gas_lower, & - scaling_gas_upper, scale_by_complement_lower, scale_by_complement_upper, & - kminor_start_lower, kminor_start_upper, totplnk, planck_frac, rayl_lower, rayl_upper, & - optimal_angle_fit)) + ! + ! Initialize RRTMGP DDT's... + ! +!$omp critical (load_lw_gas_optics) + ! Longwave k-distribution data. + call check_error_msg('rrtmgp_lw_gas_optics_init',lw_gas_props%load(gas_concentrations, & + gas_namesLW, key_speciesLW, band2gptLW, band_limsLW, press_refLW, press_ref_tropLW,& + temp_refLW, temp_ref_pLW, temp_ref_tLW, vmr_refLW, kmajorLW, kminor_lowerLW, & + kminor_upperLW, gas_minorLW, identifier_minorLW, minor_gases_lowerLW, & + minor_gases_upperLW, minor_limits_gpt_lowerLW, minor_limits_gpt_upperLW, & + minor_scales_with_density_lowerLW, minor_scales_with_density_upperLW, & + scaling_gas_lowerLW, scaling_gas_upperLW, scale_by_complement_lowerLW, & + scale_by_complement_upperLW, kminor_start_lowerLW, kminor_start_upperLW, totplnkLW,& + planck_fracLW, rayl_lowerLW, rayl_upperLW, optimal_angle_fitLW)) +!$omp end critical (load_lw_gas_optics) + + ! The minimum pressure allowed in GP RTE calculations. Used to bound uppermost layer + ! temperature (GFS_rrtmgp_pre.F90) + minGPpres = lw_gas_props%get_press_min() end subroutine rrtmgp_lw_gas_optics_init @@ -281,7 +289,7 @@ end subroutine rrtmgp_lw_gas_optics_init !! \section arg_table_rrtmgp_lw_gas_optics_run !! \htmlinclude rrtmgp_lw_gas_optics_run.html !! - subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, lw_gas_props, p_lay, p_lev, t_lay,& + subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, p_lay, p_lev, t_lay,& t_lev, tsfg, gas_concentrations, lw_optical_props_clrsky, sources, errmsg, errflg) ! Inputs @@ -290,8 +298,6 @@ subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, lw_gas_props, p_lay, p_ integer,intent(in) :: & ncol, & ! Number of horizontal points nLev ! Number of vertical levels - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: real(kind_phys), dimension(ncol,nLev), intent(in) :: & p_lay, & ! Pressure @ model layer-centers (hPa) t_lay ! Temperature (K) @@ -319,9 +325,10 @@ subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, lw_gas_props, p_lay, p_ if (.not. doLWrad) return - ! Allocate and initialize - call check_error_msg('rrtmgp_lw_gas_optics_run',lw_optical_props_clrsky%alloc_1scl(ncol, nLev, lw_gas_props)) - call check_error_msg('rrtmgp_lw_gas_optics_run',sources%alloc(ncol, nLev, lw_gas_props)) + call check_error_msg('rrtmgp_lw_gas_optics_run',& + lw_optical_props_clrsky%alloc_1scl(ncol, nLev, lw_gas_props)) + call check_error_msg('rrtmgp_lw_gas_optics_run',& + sources%alloc(ncol, nLev, lw_gas_props)) ! Gas-optics call check_error_msg('rrtmgp_lw_gas_optics_run',lw_gas_props%gas_optics(& diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index 3eab78be2..f256858d9 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -26,21 +26,28 @@ intent = in optional = F kind = len=128 -[rrtmgp_nGases] - standard_name = number_of_active_gases_used_by_RRTMGP - long_name = number of gases available used by RRTMGP +[gas_concentrations] + standard_name = Gas_concentrations_for_RRTMGP_suite + long_name = DDT containing gas concentrations for RRTMGP radiation scheme + units = DDT + dimensions = () + type = ty_gas_concs + intent = in + optional = F +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension units = count - dimensions = () + dimensions = () type = integer intent = in optional = F -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* +[nLev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer intent = in optional = F [mpirank] @@ -84,12 +91,13 @@ type = integer intent = out optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT +[minGPpres] + standard_name = minimum_pressure_in_RRTMGP + long_name = minimum pressure allowed in RRTMGP + units = Pa dimensions = () - type = ty_gas_optics_rrtmgp + type = real + kind = kind_phys intent = out optional = F @@ -121,14 +129,6 @@ type = integer intent = in optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [p_lay] standard_name = air_pressure_at_layer_for_RRTMGP_in_hPa long_name = air pressure layer diff --git a/physics/rrtmgp_lw_pre.F90 b/physics/rrtmgp_lw_pre.F90 index 358e49bee..907230180 100644 --- a/physics/rrtmgp_lw_pre.F90 +++ b/physics/rrtmgp_lw_pre.F90 @@ -5,6 +5,7 @@ module rrtmgp_lw_pre setemis ! Routine to compute surface-emissivity use mo_gas_optics_rrtmgp, only: & ty_gas_optics_rrtmgp + use rrtmgp_lw_gas_optics, only: lw_gas_props implicit none @@ -25,7 +26,7 @@ end subroutine rrtmgp_lw_pre_init !! \htmlinclude rrtmgp_lw_pre_run.html !! subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, sncovr, & - tsfg, tsfa, hprime, lw_gas_props, sfc_emiss_byband, semis, errmsg, errflg) + tsfg, tsfa, hprime, sfc_emiss_byband, semis, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -42,8 +43,6 @@ subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, snc tsfg, & ! Surface ground temperature for radiation (K) tsfa, & ! Lowest model layer air temperature for radiation (K) hprime ! Standard deviation of subgrid orography - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: spectral information for LW calculation ! Outputs real(kind_phys), dimension(lw_gas_props%get_nband(),ncol), intent(out) :: & diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta index 1f329dd8d..af287b2f7 100644 --- a/physics/rrtmgp_lw_pre.meta +++ b/physics/rrtmgp_lw_pre.meta @@ -104,14 +104,6 @@ kind = kind_phys intent = in optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [semis] standard_name = surface_longwave_emissivity long_name = surface lw emissivity in fraction diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index 321214a02..b654a0657 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -10,7 +10,7 @@ module rrtmgp_lw_rte use mo_fluxes_byband, only: ty_fluxes_byband use mo_source_functions, only: ty_source_func_lw use rrtmgp_aux, only: check_error_msg - + use rrtmgp_lw_gas_optics, only: lw_gas_props implicit none public rrtmgp_lw_rte_init, rrtmgp_lw_rte_run, rrtmgp_lw_rte_finalize @@ -29,7 +29,7 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, p_lev, lw_gas_props, sfc_emiss_byband, sources, lw_optical_props_clrsky, & + nLev, p_lev, sfc_emiss_byband, sources, lw_optical_props_clrsky, & lw_optical_props_clouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, & fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, sfculw_jac, errmsg, errflg) @@ -45,8 +45,6 @@ subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nGauss_angles ! Number of angles used in Gaussian quadrature real(kind_phys), dimension(ncol,nLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (hPa) - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: longwave spectral information real(kind_phys), dimension(lw_gas_props%get_nband(),ncol), intent(in) :: & sfc_emiss_byband ! Surface emissivity in each band type(ty_source_func_lw),intent(in) :: & diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index d295fa511..4d68ec4b6 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -82,14 +82,6 @@ kind = kind_phys intent = in optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [lw_optical_props_clrsky] standard_name = longwave_optical_properties_for_clear_sky long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_sw_aerosol_optics.F90 b/physics/rrtmgp_sw_aerosol_optics.F90 index 4bb034279..fb9306b99 100644 --- a/physics/rrtmgp_sw_aerosol_optics.F90 +++ b/physics/rrtmgp_sw_aerosol_optics.F90 @@ -3,6 +3,8 @@ module rrtmgp_sw_aerosol_optics use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_2str use rrtmgp_aux, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props + use rrtmgp_lw_gas_optics, only: lw_gas_props use module_radiation_aerosols, only: & NF_AESW, & ! Number of optical-fields in SW output (3=tau+g+omega) NF_AELW, & ! Number of optical-fields in LW output (3=tau+g+omega) @@ -30,7 +32,7 @@ end subroutine rrtmgp_sw_aerosol_optics_init !! subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer, nDay, & idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - lw_gas_props, sw_gas_props, aerodp, sw_optical_props_aerosol, errmsg, errflg ) + aerodp, sw_optical_props_aerosol, errmsg, errflg ) ! Inputs logical, intent(in) :: & @@ -58,10 +60,6 @@ subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer aerfld ! aerosol input concentrations real(kind_phys), dimension(nCol,nLev+1),intent(in) :: & p_lev ! Pressure @ layer-interfaces (Pa) - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT: spectral information for SW calculation - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! RRTMGP DDT: spectral information for LW calculation ! Outputs real(kind_phys), dimension(nCol,NSPC1), intent(inout) :: & diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/rrtmgp_sw_aerosol_optics.meta index 0ad7008c0..a8405d2a7 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/rrtmgp_sw_aerosol_optics.meta @@ -153,22 +153,6 @@ kind = kind_phys intent = in optional = F -[lw_gas_props] - standard_name = coefficients_for_lw_gas_optics - long_name = DDT containing spectral information for RRTMGP LW radiation scheme - units = DDT - dimensions = () - intent = in - type = ty_gas_optics_rrtmgp - optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [aerodp] standard_name = atmosphere_optical_thickness_due_to_ambient_aerosol_particles long_name = vertical integrated optical depth for various aerosol species diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index f08cd7181..611cb44c2 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -2,9 +2,9 @@ module rrtmgp_sw_cloud_optics use machine, only: kind_phys use mo_rte_kind, only: wl use mo_cloud_optics, only: ty_cloud_optics - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_2str use mo_rrtmg_sw_cloud_optics, only: rrtmg_sw_cloud_optics + use rrtmgp_sw_gas_optics, only: sw_gas_props use rrtmgp_aux, only: check_error_msg use netcdf @@ -12,6 +12,41 @@ module rrtmgp_sw_cloud_optics public rrtmgp_sw_cloud_optics_init, rrtmgp_sw_cloud_optics_run, rrtmgp_sw_cloud_optics_finalize + type(ty_cloud_optics) :: sw_cloud_props + real(kind_phys) :: & + radliq_facSW, & ! Factor for calculating LUT interpolation indices for liquid + radice_facSW ! Factor for calculating LUT interpolation indices for ice + real(kind_phys), dimension(:,:), allocatable :: & + lut_extliqSW, & ! LUT shortwave liquid extinction coefficient + lut_ssaliqSW, & ! LUT shortwave liquid single scattering albedo + lut_asyliqSW, & ! LUT shortwave liquid asymmetry parameter + band_limsCLDSW ! Beginning and ending wavenumber [cm -1] for each band + real(kind_phys), dimension(:,:,:), allocatable :: & + lut_exticeSW, & ! LUT shortwave ice extinction coefficient + lut_ssaiceSW, & ! LUT shortwave ice single scattering albedo + lut_asyiceSW ! LUT shortwave ice asymmetry parameter + real(kind_phys), dimension(:), allocatable :: & + pade_sizereg_extliqSW, & ! Particle size regime boundaries for shortwave liquid extinction + ! coefficient for Pade interpolation + pade_sizereg_ssaliqSW, & ! Particle size regime boundaries for shortwave liquid single + ! scattering albedo for Pade interpolation + pade_sizereg_asyliqSW, & ! Particle size regime boundaries for shortwave liquid asymmetry + ! parameter for Pade interpolation + pade_sizereg_exticeSW, & ! Particle size regime boundaries for shortwave ice extinction + ! coefficient for Pade interpolation + pade_sizereg_ssaiceSW, & ! Particle size regime boundaries for shortwave ice single + ! scattering albedo for Pade interpolation + pade_sizereg_asyiceSW ! Particle size regime boundaries for shortwave ice asymmetry + ! parameter for Pade interpolation + real(kind_phys), dimension(:,:,:), allocatable :: & + pade_extliqSW, & ! PADE coefficients for shortwave liquid extinction + pade_ssaliqSW, & ! PADE coefficients for shortwave liquid single scattering albedo + pade_asyliqSW ! PADE coefficients for shortwave liquid asymmetry parameter + real(kind_phys), dimension(:,:,:,:), allocatable :: & + pade_exticeSW, & ! PADE coefficients for shortwave ice extinction + pade_ssaiceSW, & ! PADE coefficients for shortwave ice single scattering albedo + pade_asyiceSW ! PADE coefficients for shortwave ice asymmetry parameter + ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics real(kind_phys),parameter :: & a0r = 3.07e-3, & ! @@ -19,10 +54,10 @@ module rrtmgp_sw_cloud_optics a1s = 1.5 ! real(kind_phys),dimension(:),allocatable :: b0r,b0s,b1s,c0r,c0s real(kind_phys) :: & - radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation - radliq_upr, & ! Liquid particle size upper bound for LUT interpolation - radice_lwr, & ! Ice particle size upper bound for LUT interpolation - radice_upr ! Ice particle size lower bound for LUT interpolation + radliq_lwrSW, & ! Liquid particle size lower bound for LUT interpolation + radliq_uprSW, & ! Liquid particle size upper bound for LUT interpolation + radice_lwrSW, & ! Ice particle size upper bound for LUT interpolation + radice_uprSW ! Ice particle size lower bound for LUT interpolation contains ! ###################################################################################### @@ -31,9 +66,9 @@ module rrtmgp_sw_cloud_optics !! \section arg_table_rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! - subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & + subroutine rrtmgp_sw_cloud_optics_init(nCol, nLev, nbndsGPsw, doG_cldoptics, doGP_cldoptics_PADE, & doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, & - mpirank, mpiroot, sw_cloud_props, errmsg, errflg) + mpirank, mpiroot, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -43,59 +78,22 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, integer, intent(inout) :: & nrghice ! Number of ice-roughness categories integer, intent(in) :: & + nbndsGPsw, & ! Number of bands used in shortwave. mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank - mpiroot ! Master MPI rank + mpiroot, & ! Master MPI rank + nCol, & ! Number of horizontal gridpoints + nLev ! Number of vertical levels character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory rrtmgp_sw_file_clouds ! RRTMGP file containing coefficients used to compute clouds optical properties - + ! Outputs - type(ty_cloud_optics),intent(out) :: & - sw_cloud_props ! RRTMGP DDT: shortwave spectral information character(len=*), intent(out) :: & errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error code - ! Local variables that will be passed to cloud_optics%load() - real(kind_phys) :: & - !radliq_lwr, & ! Liquid particle size lower bound for LUT interpolation - !radliq_upr, & ! Liquid particle size upper bound for LUT interpolation - radliq_fac, & ! Factor for calculating LUT interpolation indices for liquid - !radice_lwr, & ! Ice particle size upper bound for LUT interpolation - !radice_upr, & ! Ice particle size lower bound for LUT interpolation - radice_fac ! Factor for calculating LUT interpolation indices for ice - real(kind_phys), dimension(:,:), allocatable :: & - lut_extliq, & ! LUT shortwave liquid extinction coefficient - lut_ssaliq, & ! LUT shortwave liquid single scattering albedo - lut_asyliq, & ! LUT shortwave liquid asymmetry parameter - band_lims ! Beginning and ending wavenumber [cm -1] for each band - real(kind_phys), dimension(:,:,:), allocatable :: & - lut_extice, & ! LUT shortwave ice extinction coefficient - lut_ssaice, & ! LUT shortwave ice single scattering albedo - lut_asyice ! LUT shortwave ice asymmetry parameter - real(kind_phys), dimension(:), allocatable :: & - pade_sizereg_extliq, & ! Particle size regime boundaries for shortwave liquid extinction - ! coefficient for Pade interpolation - pade_sizereg_ssaliq, & ! Particle size regime boundaries for shortwave liquid single - ! scattering albedo for Pade interpolation - pade_sizereg_asyliq, & ! Particle size regime boundaries for shortwave liquid asymmetry - ! parameter for Pade interpolation - pade_sizereg_extice, & ! Particle size regime boundaries for shortwave ice extinction - ! coefficient for Pade interpolation - pade_sizereg_ssaice, & ! Particle size regime boundaries for shortwave ice single - ! scattering albedo for Pade interpolation - pade_sizereg_asyice ! Particle size regime boundaries for shortwave ice asymmetry - ! parameter for Pade interpolation - real(kind_phys), dimension(:,:,:), allocatable :: & - pade_extliq, & ! PADE coefficients for shortwave liquid extinction - pade_ssaliq, & ! PADE coefficients for shortwave liquid single scattering albedo - pade_asyliq ! PADE coefficients for shortwave liquid asymmetry parameter - real(kind_phys), dimension(:,:,:,:), allocatable :: & - pade_extice, & ! PADE coefficients for shortwave ice extinction - pade_ssaice, & ! PADE coefficients for shortwave ice single scattering albedo - pade_asyice ! PADE coefficients for shortwave ice asymmetry parameter ! Dimensions integer :: & nrghice_fromfile, nBand, nSize_liq, nSize_ice, nSizereg,& @@ -140,114 +138,105 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, status = nf90_inq_dimid(ncid, 'pair', dimid) status = nf90_inquire_dimension(ncid, dimid, len=nPairs) - ! Has the number of ice-roughnesses to use been provided from the namelist? - ! If not provided, use default number of ice-roughness categories - if (nrghice .eq. 0) then - nrghice = nrghice_default - else - nrghice = nrghice_fromfile - ! If provided in the namelist, check to ensure that number of ice-roughness categories is feasible. - if (nrghice .gt. nrghice_fromfile) then - errmsg = 'Number of RRTMGP ice-roughness categories requested in namelist file is not allowed. Using default number of categories.' - nrghice = nrghice_default - endif - endif + ! Has the number of ice-roughnesses provided from the namelist? + ! If not, use nrghice from cloud-optics file + if (nrghice .eq. 0) nrghice = nrghice_fromfile ! Allocate space for arrays if (doGP_cldoptics_LUT) then - allocate(lut_extliq(nSize_liq, nBand)) - allocate(lut_ssaliq(nSize_liq, nBand)) - allocate(lut_asyliq(nSize_liq, nBand)) - allocate(lut_extice(nSize_ice, nBand, nrghice_fromfile)) - allocate(lut_ssaice(nSize_ice, nBand, nrghice_fromfile)) - allocate(lut_asyice(nSize_ice, nBand, nrghice_fromfile)) + allocate(lut_extliqSW(nSize_liq, nBand)) + allocate(lut_ssaliqSW(nSize_liq, nBand)) + allocate(lut_asyliqSW(nSize_liq, nBand)) + allocate(lut_exticeSW(nSize_ice, nBand, nrghice)) + allocate(lut_ssaiceSW(nSize_ice, nBand, nrghice)) + allocate(lut_asyiceSW(nSize_ice, nBand, nrghice)) endif if (doGP_cldoptics_PADE) then - allocate(pade_extliq(nBand, nSizeReg, nCoeff_ext )) - allocate(pade_ssaliq(nBand, nSizeReg, nCoeff_ssa_g)) - allocate(pade_asyliq(nBand, nSizeReg, nCoeff_ssa_g)) - allocate(pade_extice(nBand, nSizeReg, nCoeff_ext, nrghice_fromfile)) - allocate(pade_ssaice(nBand, nSizeReg, nCoeff_ssa_g, nrghice_fromfile)) - allocate(pade_asyice(nBand, nSizeReg, nCoeff_ssa_g, nrghice_fromfile)) - allocate(pade_sizereg_extliq(nBound)) - allocate(pade_sizereg_ssaliq(nBound)) - allocate(pade_sizereg_asyliq(nBound)) - allocate(pade_sizereg_extice(nBound)) - allocate(pade_sizereg_ssaice(nBound)) - allocate(pade_sizereg_asyice(nBound)) + allocate(pade_extliqSW(nBand, nSizeReg, nCoeff_ext )) + allocate(pade_ssaliqSW(nBand, nSizeReg, nCoeff_ssa_g)) + allocate(pade_asyliqSW(nBand, nSizeReg, nCoeff_ssa_g)) + allocate(pade_exticeSW(nBand, nSizeReg, nCoeff_ext, nrghice)) + allocate(pade_ssaiceSW(nBand, nSizeReg, nCoeff_ssa_g, nrghice)) + allocate(pade_asyiceSW(nBand, nSizeReg, nCoeff_ssa_g, nrghice)) + allocate(pade_sizereg_extliqSW(nBound)) + allocate(pade_sizereg_ssaliqSW(nBound)) + allocate(pade_sizereg_asyliqSW(nBound)) + allocate(pade_sizereg_exticeSW(nBound)) + allocate(pade_sizereg_ssaiceSW(nBound)) + allocate(pade_sizereg_asyiceSW(nBound)) endif - allocate(band_lims(2,nBand)) + allocate(band_limsCLDSW(2,nBand)) ! Read in fields from file if (doGP_cldoptics_LUT) then write (*,*) 'Reading RRTMGP shortwave cloud data (LUT) ... ' status = nf90_inq_varid(ncid,'radliq_lwr',varID) - status = nf90_get_var(ncid,varID,radliq_lwr) + status = nf90_get_var(ncid,varID,radliq_lwrSW) status = nf90_inq_varid(ncid,'radliq_upr',varID) - status = nf90_get_var(ncid,varID,radliq_upr) + status = nf90_get_var(ncid,varID,radliq_uprSW) status = nf90_inq_varid(ncid,'radliq_fac',varID) - status = nf90_get_var(ncid,varID,radliq_fac) + status = nf90_get_var(ncid,varID,radliq_facSW) status = nf90_inq_varid(ncid,'radice_lwr',varID) - status = nf90_get_var(ncid,varID,radice_lwr) + status = nf90_get_var(ncid,varID,radice_lwrSW) status = nf90_inq_varid(ncid,'radice_upr',varID) - status = nf90_get_var(ncid,varID,radice_upr) + status = nf90_get_var(ncid,varID,radice_uprSW) status = nf90_inq_varid(ncid,'radice_fac',varID) - status = nf90_get_var(ncid,varID,radice_fac) + status = nf90_get_var(ncid,varID,radice_facSW) status = nf90_inq_varid(ncid,'lut_extliq',varID) - status = nf90_get_var(ncid,varID,lut_extliq) + status = nf90_get_var(ncid,varID,lut_extliqSW) status = nf90_inq_varid(ncid,'lut_ssaliq',varID) - status = nf90_get_var(ncid,varID,lut_ssaliq) + status = nf90_get_var(ncid,varID,lut_ssaliqSW) status = nf90_inq_varid(ncid,'lut_asyliq',varID) - status = nf90_get_var(ncid,varID,lut_asyliq) + status = nf90_get_var(ncid,varID,lut_asyliqSW) status = nf90_inq_varid(ncid,'lut_extice',varID) - status = nf90_get_var(ncid,varID,lut_extice) + status = nf90_get_var(ncid,varID,lut_exticeSW) status = nf90_inq_varid(ncid,'lut_ssaice',varID) - status = nf90_get_var(ncid,varID,lut_ssaice) + status = nf90_get_var(ncid,varID,lut_ssaiceSW) status = nf90_inq_varid(ncid,'lut_asyice',varID) - status = nf90_get_var(ncid,varID,lut_asyice) + status = nf90_get_var(ncid,varID,lut_asyiceSW) status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varID) - status = nf90_get_var(ncid,varID,band_lims) + status = nf90_get_var(ncid,varID,band_limsCLDSW) endif if (doGP_cldoptics_PADE) then write (*,*) 'Reading RRTMGP shortwave cloud data (PADE) ... ' status = nf90_inq_varid(ncid,'radliq_lwr',varID) - status = nf90_get_var(ncid,varID,radliq_lwr) + status = nf90_get_var(ncid,varID,radliq_lwrSW) status = nf90_inq_varid(ncid,'radliq_upr',varID) - status = nf90_get_var(ncid,varID,radliq_upr) + status = nf90_get_var(ncid,varID,radliq_uprSW) status = nf90_inq_varid(ncid,'radliq_fac',varID) - status = nf90_get_var(ncid,varID,radliq_fac) + status = nf90_get_var(ncid,varID,radliq_facSW) status = nf90_inq_varid(ncid,'radice_lwr',varID) - status = nf90_get_var(ncid,varID,radice_lwr) + status = nf90_get_var(ncid,varID,radice_lwrSW) status = nf90_inq_varid(ncid,'radice_upr',varID) - status = nf90_get_var(ncid,varID,radice_upr) + status = nf90_get_var(ncid,varID,radice_uprSW) status = nf90_inq_varid(ncid,'radice_fac',varID) - status = nf90_get_var(ncid,varID,radice_fac) + status = nf90_get_var(ncid,varID,radice_facSW) status = nf90_inq_varid(ncid,'pade_extliq',varID) - status = nf90_get_var(ncid,varID,pade_extliq) + status = nf90_get_var(ncid,varID,pade_extliqSW) status = nf90_inq_varid(ncid,'pade_ssaliq',varID) - status = nf90_get_var(ncid,varID,pade_ssaliq) + status = nf90_get_var(ncid,varID,pade_ssaliqSW) status = nf90_inq_varid(ncid,'pade_asyliq',varID) - status = nf90_get_var(ncid,varID,pade_asyliq) + status = nf90_get_var(ncid,varID,pade_asyliqSW) status = nf90_inq_varid(ncid,'pade_extice',varID) - status = nf90_get_var(ncid,varID,pade_extice) + status = nf90_get_var(ncid,varID,pade_exticeSW) status = nf90_inq_varid(ncid,'pade_ssaice',varID) - status = nf90_get_var(ncid,varID,pade_ssaice) + status = nf90_get_var(ncid,varID,pade_ssaiceSW) status = nf90_inq_varid(ncid,'pade_asyice',varID) - status = nf90_get_var(ncid,varID,pade_asyice) + status = nf90_get_var(ncid,varID,pade_asyiceSW) status = nf90_inq_varid(ncid,'pade_sizreg_extliq',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_extliq) + status = nf90_get_var(ncid,varID,pade_sizereg_extliqSW) status = nf90_inq_varid(ncid,'pade_sizreg_ssaliq',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_ssaliq) + status = nf90_get_var(ncid,varID,pade_sizereg_ssaliqSW) status = nf90_inq_varid(ncid,'pade_sizreg_asyliq',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_asyliq) + status = nf90_get_var(ncid,varID,pade_sizereg_asyliqSW) status = nf90_inq_varid(ncid,'pade_sizreg_extice',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_extice) + status = nf90_get_var(ncid,varID,pade_sizereg_exticeSW) status = nf90_inq_varid(ncid,'pade_sizreg_ssaice',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_ssaice) + status = nf90_get_var(ncid,varID,pade_sizereg_ssaiceSW) status = nf90_inq_varid(ncid,'pade_sizreg_asyice',varID) - status = nf90_get_var(ncid,varID,pade_sizereg_asyice) + status = nf90_get_var(ncid,varID,pade_sizereg_asyiceSW) status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varID) - status = nf90_get_var(ncid,varID,band_lims) + status = nf90_get_var(ncid,varID,band_limsCLDSW) endif ! Close file @@ -256,19 +245,26 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, ! Load tables data for RRTMGP cloud-optics if (doGP_cldoptics_LUT) then - call check_error_msg('sw_cloud_optics_init',sw_cloud_props%load(band_lims, & - radliq_lwr, radliq_upr, radliq_fac, radice_lwr, radice_upr, radice_fac, & - lut_extliq, lut_ssaliq, lut_asyliq, lut_extice, lut_ssaice, lut_asyice)) +!$omp critical (load_sw_cloud_props_LUTs) + call check_error_msg('sw_cloud_optics_init',sw_cloud_props%load(band_limsCLDSW, & + radliq_lwrSW, radliq_uprSW, radliq_facSW, radice_lwrSW, radice_uprSW, radice_facSW, & + lut_extliqSW, lut_ssaliqSW, lut_asyliqSW, lut_exticeSW, lut_ssaiceSW, lut_asyiceSW)) +!$omp end critical (load_sw_cloud_props_LUTs) endif if (doGP_cldoptics_PADE) then - call check_error_msg('sw_cloud_optics_init', sw_cloud_props%load(band_lims, & - pade_extliq, pade_ssaliq, pade_asyliq, pade_extice, pade_ssaice, pade_asyice,& - pade_sizereg_extliq, pade_sizereg_ssaliq, pade_sizereg_asyliq, & - pade_sizereg_extice, pade_sizereg_ssaice, pade_sizereg_asyice)) +!$omp critical (load_sw_cloud_props_PADE_approx) + call check_error_msg('sw_cloud_optics_init', sw_cloud_props%load(band_limsCLDSW, & + pade_extliqSW, pade_ssaliqSW, pade_asyliqSW, pade_exticeSW, pade_ssaiceSW, pade_asyiceSW,& + pade_sizereg_extliqSW, pade_sizereg_ssaliqSW, pade_sizereg_asyliqSW, & + pade_sizereg_exticeSW, pade_sizereg_ssaiceSW, pade_sizereg_asyiceSW)) +!$omp end critical (load_sw_cloud_props_PADE_approx) endif +!$omp critical (load_sw_cloud_props_nrghice) call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(nrghice)) - +!$omp end critical (load_sw_cloud_props_nrghice) + ! Initialize coefficients for rain and snow(+groupel) cloud optics +!$omp critical (load_sw_precip_props) allocate(b0r(sw_cloud_props%get_nband()),b0s(sw_cloud_props%get_nband()), & b1s(sw_cloud_props%get_nband()),c0r(sw_cloud_props%get_nband()), & c0s(sw_cloud_props%get_nband())) @@ -282,7 +278,8 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, 0.944, 0.894, 0.884, 0.883, 0.883, 0.883, 0.883/) c0s = (/0.970, 0.970, 0.970, 0.970, 0.970, 0.970, 0.970, & 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/) - +!$omp end critical (load_sw_precip_props) + end subroutine rrtmgp_sw_cloud_optics_init ! ######################################################################################### @@ -292,9 +289,9 @@ end subroutine rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_sw_cloud_optics.html !! subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, nCol, nLev, nDay, idxday, nrghice, cld_frac,& + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nCol, nLev, nDay, nbndsGPsw, idxday, nrghice, cld_frac,& cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & - precip_frac, sw_cloud_props, sw_gas_props, sw_optical_props_cloudsByBand, & + precip_frac, sw_optical_props_cloudsByBand, & sw_optical_props_precipByBand, cldtausw, errmsg, errflg) ! Inputs @@ -304,6 +301,7 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw doGP_cldoptics_PADE, & ! Use RRTMGP cloud-optics: PADE approximation? doGP_cldoptics_LUT ! Use RRTMGP cloud-optics: LUTs? integer, intent(in) :: & + nbndsGPsw, & ! Number of shortwave bands nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels nday, & ! Number of daylit points. @@ -323,11 +321,7 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw cld_rwp, & ! Cloud rain water path cld_rerain, & ! Cloud rain effective radius precip_frac ! Precipitation fraction by layer - type(ty_cloud_optics),intent(in) :: & - sw_cloud_props ! RRTMGP DDT: shortwave cloud properties - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT: shortwave K-distribution data - + ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message @@ -343,9 +337,10 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw integer :: iDay, iLay, iBand real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, & tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2 - real(kind_phys), dimension(nday,nLev,sw_gas_props%get_nband()) :: & + real(kind_phys), dimension(nday,nLev,nbndsGPsw) :: & tau_cld, ssa_cld, asy_cld, tau_precip, ssa_precip, asy_precip - + type(ty_optical_props_2str) :: sw_optical_props_cloudsByBand_daylit + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -355,23 +350,19 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw ! Only process sunlit points... if (nDay .gt. 0) then - ! Allocate space for RRTMGP DDTs containing cloud/precipitation radiative properties - ! Cloud optics [nday,nLev,nBands] - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_cloudsByBand%alloc_2str(& - nday, nLev, sw_gas_props%get_band_lims_wavenumber())) - sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys - - ! Cloud-precipitation optics [nday,nLev,nBands] - call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_precipByBand%alloc_2str(& - nday, nLev, sw_gas_props%get_band_lims_wavenumber())) - sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys - sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys - sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys - ! Compute cloud/precipitation optics. if (doGP_cldoptics_PADE .or. doGP_cldoptics_LUT) then + call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_cloudsByBand%alloc_2str(& + nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys + sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys + sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys + call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_precipByBand%alloc_2str(& + nday, nLev, sw_cloud_props%get_band_lims_wavenumber())) + sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys + sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys + sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys + ! RRTMGP cloud-optics. call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_cloud_props%cloud_optics(& cld_lwp(idxday(1:nday),:), & ! IN - Cloud liquid water path @@ -393,7 +384,7 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw endif ! Rain/Snow single-scattering albedo and asymmetry (Band dependent) - do iBand=1,sw_cloud_props%get_nband() + do iBand=1,nbndsGPsw ! By species ssa_rain = tau_rain*(1.-b0r(iBand)) asy_rain = ssa_rain*c0r(iBand) @@ -407,27 +398,38 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) za1 = asyw * asyw za2 = ssaw * za1 - sw_optical_props_precipByBand%tau(iDay,iLay,iBand) = (1._kind_phys - za2) * tau_prec - sw_optical_props_precipByBand%ssa(iDay,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) - sw_optical_props_precipByBand%g(iDay,iLay,iBand) = asyw/(1+asyw) + sw_optical_props_precipByBand%tau(idxday(iDay),iLay,iBand) = (1._kind_phys - za2) * tau_prec + sw_optical_props_precipByBand%ssa(idxday(iDay),iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) + sw_optical_props_precipByBand%g(idxday(iDay),iLay,iBand) = asyw/(1+asyw) enddo endif enddo enddo endif if (doG_cldoptics) then + call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_cloudsByBand%alloc_2str(& + nday, nLev, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_cloudsByBand%tau(:,:,:) = 0._kind_phys + sw_optical_props_cloudsByBand%ssa(:,:,:) = 1._kind_phys + sw_optical_props_cloudsByBand%g(:,:,:) = 0._kind_phys + call check_error_msg('rrtmgp_sw_cloud_optics_run',sw_optical_props_precipByBand%alloc_2str(& + nday, nLev, sw_gas_props%get_band_lims_wavenumber())) + sw_optical_props_precipByBand%tau(:,:,:) = 0._kind_phys + sw_optical_props_precipByBand%ssa(:,:,:) = 1._kind_phys + sw_optical_props_precipByBand%g(:,:,:) = 0._kind_phys + ! RRTMG cloud(+precipitation) optics if (any(cld_frac .gt. 0)) then - call rrtmg_sw_cloud_optics(nday, nLev, sw_gas_props%get_nband(), & - cld_lwp(idxday(1:nday),:), cld_reliq(idxday(1:nday),:), & - cld_iwp(idxday(1:nday),:), cld_reice(idxday(1:nday),:), & - cld_rwp(idxday(1:nday),:), cld_rerain(idxday(1:nday),:), & - cld_swp(idxday(1:nday),:), cld_resnow(idxday(1:nday),:), & - cld_frac(idxday(1:nday),:), icliq_sw, icice_sw, & - tau_cld, ssa_cld, asy_cld, & + call rrtmg_sw_cloud_optics(nday, nLev, sw_gas_props%get_nband(), & + cld_lwp(idxday(1:nday),:), cld_reliq(idxday(1:nday),:), & + cld_iwp(idxday(1:nday),:), cld_reice(idxday(1:nday),:), & + cld_rwp(idxday(1:nday),:), cld_rerain(idxday(1:nday),:), & + cld_swp(idxday(1:nday),:), cld_resnow(idxday(1:nday),:), & + cld_frac(idxday(1:nday),:), icliq_sw, icice_sw, & + tau_cld, ssa_cld, asy_cld, & tau_precip, ssa_precip, asy_precip) - - ! Cloud-optics (Need to reorder from G->GP band conventions) + + ! Cloud-optics (Need to reorder from G->GP band conventions) sw_optical_props_cloudsByBand%tau(:,:,1) = tau_cld(:,:,sw_gas_props%get_nband()) sw_optical_props_cloudsByBand%ssa(:,:,1) = ssa_cld(:,:,sw_gas_props%get_nband()) sw_optical_props_cloudsByBand%g(:,:,1) = asy_cld(:,:,sw_gas_props%get_nband()) @@ -441,6 +443,7 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw sw_optical_props_precipByBand%tau(:,:,2:sw_gas_props%get_nband()) = tau_precip(:,:,1:sw_gas_props%get_nband()-1) sw_optical_props_precipByBand%ssa(:,:,2:sw_gas_props%get_nband()) = ssa_precip(:,:,1:sw_gas_props%get_nband()-1) sw_optical_props_precipByBand%g(:,:,2:sw_gas_props%get_nband()) = asy_precip(:,:,1:sw_gas_props%get_nband()-1) + endif endif diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index 4439a607b..3999f844b 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -7,6 +7,30 @@ [ccpp-arg-table] name = rrtmgp_sw_cloud_optics_init type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[nLev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[nbndsGPsw] + standard_name = number_of_sw_bands_rrtmgp + long_name = number of sw bands used in RRTMGP + units = count + dimensions = () + type = integer + intent = in + optional = F [doG_cldoptics] standard_name = flag_to_calc_lw_cld_optics_using_RRTMG long_name = logical flag to control cloud optics scheme. @@ -98,15 +122,6 @@ type = integer intent = out optional = F -[sw_cloud_props] - standard_name = coefficients_for_sw_cloud_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_cloud_optics - intent = out - optional = F - ######################################################################## [ccpp-arg-table] name = rrtmgp_sw_cloud_optics_run @@ -273,20 +288,12 @@ kind = kind_phys intent = in optional = F -[sw_cloud_props] - standard_name = coefficients_for_sw_cloud_optics - long_name = DDT containing spectral information for cloudy RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_cloud_optics - intent = in - optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp +[nbndsGPsw] + standard_name = number_of_sw_bands_rrtmgp + long_name = number of sw bands used in RRTMGP + units = count + dimensions = () + type = integer intent = in optional = F [nday] diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index e74ceb4e5..b969c50a9 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -5,6 +5,7 @@ module rrtmgp_sw_cloud_sampling use rrtmgp_sampling, only: sampled_mask, draw_samples use mersenne_twister, only: random_setseed, random_number, random_stat use rrtmgp_aux, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props use netcdf implicit none @@ -16,10 +17,8 @@ module rrtmgp_sw_cloud_sampling !! \section arg_table_rrtmgp_sw_cloud_sampling_init !! \htmlinclude rrtmgp_sw_cloud_sampling.html !! - subroutine rrtmgp_sw_cloud_sampling_init(sw_gas_props, ipsdsw0, errmsg, errflg) - ! Inputs - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT: K-distribution data + subroutine rrtmgp_sw_cloud_sampling_init(ipsdsw0, errmsg, errflg) + ! Outputs integer, intent(out) :: & ipsdsw0 ! Initial permutation seed for McICA @@ -46,7 +45,7 @@ end subroutine rrtmgp_sw_cloud_sampling_init subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, ipsdsw0, idxday, iovr, & iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, & icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, & - sw_gas_props, sw_optical_props_cloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_cloudsByBand, sw_optical_props_precipByBand, & sw_optical_props_clouds, sw_optical_props_precip, errmsg, errflg) ! Inputs @@ -78,8 +77,6 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, ipsdsw0, idxd real(kind_phys), dimension(ncol,nLev), intent(in) :: & cloud_overlap_param, & ! Cloud overlap parameter precip_overlap_param ! Precipitation overlap parameter - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT: K-distribution data type(ty_optical_props_2str),intent(in) :: & sw_optical_props_cloudsByBand, & ! RRTMGP DDT: Shortwave optical properties in each band (clouds) sw_optical_props_precipByBand ! RRTMGP DDT: Shortwave optical properties in each band (precipitation) diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index 01a311fd4..cda2aaa60 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -7,14 +7,6 @@ [ccpp-arg-table] name = rrtmgp_sw_cloud_sampling_init type = scheme -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [ipsdsw0] standard_name = initial_permutation_seed_sw long_name = initial seed for McICA SW @@ -200,14 +192,6 @@ type = real kind = kind_phys intent = in - optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in optional = F [sw_optical_props_cloudsByBand] standard_name = shortwave_optical_properties_for_cloudy_atmosphere_by_band diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index ac643e71d..668582d87 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -10,7 +10,57 @@ module rrtmgp_sw_gas_optics use netcdf implicit none - + ! RRTMGP k-distribution LUTs. + type(ty_gas_optics_rrtmgp) :: sw_gas_props + integer, dimension(:), allocatable :: & + kminor_start_lowerSW, & ! Starting index in the [1, nContributors] vector for a contributor + ! given by \"minor_gases_lower\" (lower atmosphere) + kminor_start_upperSW ! Starting index in the [1, nContributors] vector for a contributor + ! given by \"minor_gases_upper\" (upper atmosphere) + integer, dimension(:,:), allocatable :: & + band2gptSW, & ! Beginning and ending gpoint for each band + minor_limits_gpt_lowerSW, & ! Beginning and ending gpoint for each minor interval in lower atmosphere + minor_limits_gpt_upperSW ! Beginning and ending gpoint for each minor interval in upper atmosphere + integer, dimension(:,:,:), allocatable :: & + key_speciesSW ! Key species pair for each band + real(kind_phys) :: & + press_ref_tropSW, & ! Reference pressure separating the lower and upper atmosphere [Pa] + temp_ref_pSW, & ! Standard spectroscopic reference pressure [Pa] + temp_ref_tSW, & ! Standard spectroscopic reference temperature [K] + tsi_defaultSW, & ! + mg_defaultSW, & ! Mean value of Mg2 index over the average solar cycle from the NRLSSI2 model of solar variability + sb_defaultSW ! Mean value of sunspot index over the average solar cycle from the NRLSSI2 model of solar variability + real(kind_phys), dimension(:), allocatable :: & + press_refSW, & ! Pressures for reference atmosphere; press_ref(# reference layers) [Pa] + temp_refSW, & ! Temperatures for reference atmosphere; temp_ref(# reference layers) [K] + solar_quietSW, & ! Spectrally-dependent quiet sun irradiance from the NRLSSI2 model of solar variability + solar_facularSW, & ! Spectrally-dependent facular term from the NRLSSI2 model of solar variability + solar_sunspotSW ! Spectrally-dependent sunspot term from the NRLSSI2 model of solar variability + real(kind_phys), dimension(:,:), allocatable :: & + band_limsSW ! Beginning and ending wavenumber [cm -1] for each band + real(kind_phys), dimension(:,:,:), allocatable :: & + vmr_refSW, & ! Volume mixing ratios for reference atmosphere + kminor_lowerSW, & ! (transformed from [nTemp x nEta x nGpt x nAbsorbers] array to + ! [nTemp x nEta x nContributors] array) + kminor_upperSW, & ! (transformed from [nTemp x nEta x nGpt x nAbsorbers] array to + ! [nTemp x nEta x nContributors] array) + rayl_lowerSW, & ! Stored coefficients due to rayleigh scattering contribution + rayl_upperSW ! Stored coefficients due to rayleigh scattering contribution + real(kind_phys), dimension(:,:,:,:), allocatable :: & + kmajorSW ! Stored absorption coefficients due to major absorbing gases + character(len=32), dimension(:), allocatable :: & + gas_namesSW, & ! Names of absorbing gases + gas_minorSW, & ! Name of absorbing minor gas + identifier_minorSW, & ! Unique string identifying minor gas + minor_gases_lowerSW, & ! Names of minor absorbing gases in lower atmosphere + minor_gases_upperSW, & ! Names of minor absorbing gases in upper atmosphere + scaling_gas_lowerSW, & ! Absorption also depends on the concentration of this gas + scaling_gas_upperSW ! Absorption also depends on the concentration of this gas + logical(wl), dimension(:), allocatable :: & + minor_scales_with_density_lowerSW, & ! Density scaling is applied to minor absorption coefficients + minor_scales_with_density_upperSW, & ! Density scaling is applied to minor absorption coefficients + scale_by_complement_lowerSW, & ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) + scale_by_complement_upperSW ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) contains ! ######################################################################################### @@ -19,85 +69,32 @@ module rrtmgp_sw_gas_optics !! \section arg_table_rrtmgp_sw_gas_optics_init !! \htmlinclude rrtmgp_sw_gas_optics.html !! - subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp_nGases, & - active_gases_array, mpicomm, mpirank, mpiroot, sw_gas_props, errmsg, errflg) + subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, rrtmgp_sw_file_gas, gas_concentrations, & + mpicomm, mpirank, mpiroot, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory rrtmgp_sw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties - integer, intent(in) :: & - rrtmgp_nGases ! Number of trace gases active in RRTMGP - character(len=*),dimension(rrtmgp_nGases), intent(in) :: & - active_gases_array ! Character array containing trace gases to include in RRTMGP integer,intent(in) :: & + nCol, & ! Number of horizontal gridpoints. + nLev, & ! Number of vertical levels. + nThreads, & ! Number of openMP threads mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank + type(ty_gas_concs),intent(in) :: & + gas_concentrations ! RRTMGP DDT containing active trace gases. ! Outputs character(len=*), intent(out) :: & errmsg ! CCPP error message integer, intent(out) :: & errflg ! CCPP error code - type(ty_gas_optics_rrtmgp),intent(out) :: & - sw_gas_props ! RRTMGP DDT: shortwave spectral information - ! Variables that will be passed to gas_optics%load() - type(ty_gas_concs) :: & - gas_concentrations - integer, dimension(:), allocatable :: & - kminor_start_lower, & ! Starting index in the [1, nContributors] vector for a contributor - ! given by \"minor_gases_lower\" (lower atmosphere) - kminor_start_upper ! Starting index in the [1, nContributors] vector for a contributor - ! given by \"minor_gases_upper\" (upper atmosphere) - integer, dimension(:,:), allocatable :: & - band2gpt, & ! Beginning and ending gpoint for each band - minor_limits_gpt_lower, & ! Beginning and ending gpoint for each minor interval in lower atmosphere - minor_limits_gpt_upper ! Beginning and ending gpoint for each minor interval in upper atmosphere - integer, dimension(:,:,:), allocatable :: & - key_species ! Key species pair for each band - real(kind_phys) :: & - press_ref_trop, & ! Reference pressure separating the lower and upper atmosphere [Pa] - temp_ref_p, & ! Standard spectroscopic reference pressure [Pa] - temp_ref_t, & ! Standard spectroscopic reference temperature [K] - tsi_default, & ! - mg_default, & ! - sb_default ! - real(kind_phys), dimension(:), allocatable :: & - press_ref, & ! Pressures for reference atmosphere; press_ref(# reference layers) [Pa] - temp_ref, & ! Temperatures for reference atmosphere; temp_ref(# reference layers) [K] - solar_quiet, & ! - solar_facular, & ! - solar_sunspot ! - real(kind_phys), dimension(:,:), allocatable :: & - band_lims ! Beginning and ending wavenumber [cm -1] for each band - real(kind_phys), dimension(:,:,:), allocatable :: & - vmr_ref, & ! Volume mixing ratios for reference atmosphere - kminor_lower, & ! (transformed from [nTemp x nEta x nGpt x nAbsorbers] array to - ! [nTemp x nEta x nContributors] array) - kminor_upper, & ! (transformed from [nTemp x nEta x nGpt x nAbsorbers] array to - ! [nTemp x nEta x nContributors] array) - rayl_lower, & ! Stored coefficients due to rayleigh scattering contribution - rayl_upper ! Stored coefficients due to rayleigh scattering contribution - real(kind_phys), dimension(:,:,:,:), allocatable :: & - kmajor ! Stored absorption coefficients due to major absorbing gases - character(len=32), dimension(:), allocatable :: & - gas_names, & ! Names of absorbing gases - gas_minor, & ! Name of absorbing minor gas - identifier_minor, & ! Unique string identifying minor gas - minor_gases_lower, & ! Names of minor absorbing gases in lower atmosphere - minor_gases_upper, & ! Names of minor absorbing gases in upper atmosphere - scaling_gas_lower, & ! Absorption also depends on the concentration of this gas - scaling_gas_upper ! Absorption also depends on the concentration of this gas - logical(wl), dimension(:), allocatable :: & - minor_scales_with_density_lower, & ! Density scaling is applied to minor absorption coefficients - minor_scales_with_density_upper, & ! Density scaling is applied to minor absorption coefficients - scale_by_complement_lower, & ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) - scale_by_complement_upper ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) ! Dimensions integer :: & - ntemps, npress, ngpts, nabsorbers, nextrabsorbers, & + ntemps, npress, ngptsSW, nabsorbers, nextrabsorbers, & nminorabsorbers, nmixingfracs, nlayers, nbnds, npairs, & nminor_absorber_intervals_lower, nminor_absorber_intervals_upper, & ncontributors_lower, ncontributors_upper @@ -137,7 +134,7 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp status = nf90_inq_dimid(ncid, 'bnd', dimid) status = nf90_inquire_dimension(ncid, dimid, len=nbnds) status = nf90_inq_dimid(ncid, 'gpt', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=ngpts) + status = nf90_inquire_dimension(ncid, dimid, len=ngptsSW) status = nf90_inq_dimid(ncid, 'pair', dimid) status = nf90_inquire_dimension(ncid, dimid, len=npairs) status = nf90_inq_dimid(ncid, 'contributors_lower',dimid) @@ -150,138 +147,176 @@ subroutine rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp status = nf90_inquire_dimension(ncid, dimid, len=nminor_absorber_intervals_upper) ! Allocate space for arrays - allocate(gas_names(nabsorbers)) - allocate(scaling_gas_lower(nminor_absorber_intervals_lower)) - allocate(scaling_gas_upper(nminor_absorber_intervals_upper)) - allocate(gas_minor(nminorabsorbers)) - allocate(identifier_minor(nminorabsorbers)) - allocate(minor_gases_lower(nminor_absorber_intervals_lower)) - allocate(minor_gases_upper(nminor_absorber_intervals_upper)) - allocate(minor_limits_gpt_lower(npairs,nminor_absorber_intervals_lower)) - allocate(minor_limits_gpt_upper(npairs,nminor_absorber_intervals_upper)) - allocate(band2gpt(2,nbnds)) - allocate(key_species(2,nlayers,nbnds)) - allocate(band_lims(2,nbnds)) - allocate(press_ref(npress)) - allocate(temp_ref(ntemps)) - allocate(vmr_ref(nlayers, nextrabsorbers, ntemps)) - allocate(kminor_lower(ncontributors_lower, nmixingfracs, ntemps)) - allocate(kmajor(ngpts, nmixingfracs, npress+1, ntemps)) - allocate(kminor_start_lower(nminor_absorber_intervals_lower)) - allocate(kminor_upper(ncontributors_upper, nmixingfracs, ntemps)) - allocate(kminor_start_upper(nminor_absorber_intervals_upper)) - allocate(minor_scales_with_density_lower(nminor_absorber_intervals_lower)) - allocate(minor_scales_with_density_upper(nminor_absorber_intervals_upper)) - allocate(scale_by_complement_lower(nminor_absorber_intervals_lower)) - allocate(scale_by_complement_upper(nminor_absorber_intervals_upper)) - allocate(rayl_upper(ngpts, nmixingfracs, ntemps)) - allocate(rayl_lower(ngpts, nmixingfracs, ntemps)) - allocate(solar_quiet(ngpts)) - allocate(solar_facular(ngpts)) - allocate(solar_sunspot(ngpts)) - allocate(temp1(nminor_absorber_intervals_lower)) - allocate(temp2(nminor_absorber_intervals_upper)) - allocate(temp3(nminor_absorber_intervals_lower)) - allocate(temp4(nminor_absorber_intervals_upper)) + if (.not. allocated(gas_namesSW)) & + allocate(gas_namesSW(nabsorbers)) + if (.not. allocated(scaling_gas_lowerSW)) & + allocate(scaling_gas_lowerSW(nminor_absorber_intervals_lower)) + if (.not. allocated(scaling_gas_upperSW)) & + allocate(scaling_gas_upperSW(nminor_absorber_intervals_upper)) + if (.not. allocated(gas_minorSW)) & + allocate(gas_minorSW(nminorabsorbers)) + if (.not. allocated(identifier_minorSW)) & + allocate(identifier_minorSW(nminorabsorbers)) + if (.not. allocated(minor_gases_lowerSW)) & + allocate(minor_gases_lowerSW(nminor_absorber_intervals_lower)) + if (.not. allocated(minor_gases_upperSW)) & + allocate(minor_gases_upperSW(nminor_absorber_intervals_upper)) + if (.not. allocated(minor_limits_gpt_lowerSW)) & + allocate(minor_limits_gpt_lowerSW(npairs,nminor_absorber_intervals_lower)) + if (.not. allocated(minor_limits_gpt_upperSW)) & + allocate(minor_limits_gpt_upperSW(npairs,nminor_absorber_intervals_upper)) + if (.not. allocated(band2gptSW)) & + allocate(band2gptSW(2,nbnds)) + if (.not. allocated(key_speciesSW)) & + allocate(key_speciesSW(2,nlayers,nbnds)) + if (.not. allocated(band_limsSW)) & + allocate(band_limsSW(2,nbnds)) + if (.not. allocated(press_refSW)) & + allocate(press_refSW(npress)) + if (.not. allocated(temp_refSW)) & + allocate(temp_refSW(ntemps)) + if (.not. allocated(vmr_refSW)) & + allocate(vmr_refSW(nlayers, nextrabsorbers, ntemps)) + if (.not. allocated(kminor_lowerSW)) & + allocate(kminor_lowerSW(ncontributors_lower, nmixingfracs, ntemps)) + if (.not. allocated(kmajorSW)) & + allocate(kmajorSW(ngptsSW, nmixingfracs, npress+1, ntemps)) + if (.not. allocated(kminor_start_lowerSW)) & + allocate(kminor_start_lowerSW(nminor_absorber_intervals_lower)) + if (.not. allocated(kminor_upperSW)) & + allocate(kminor_upperSW(ncontributors_upper, nmixingfracs, ntemps)) + if (.not. allocated(kminor_start_upperSW)) & + allocate(kminor_start_upperSW(nminor_absorber_intervals_upper)) + if (.not. allocated(minor_scales_with_density_lowerSW)) & + allocate(minor_scales_with_density_lowerSW(nminor_absorber_intervals_lower)) + if (.not. allocated(minor_scales_with_density_upperSW)) & + allocate(minor_scales_with_density_upperSW(nminor_absorber_intervals_upper)) + if (.not. allocated(scale_by_complement_lowerSW)) & + allocate(scale_by_complement_lowerSW(nminor_absorber_intervals_lower)) + if (.not. allocated(scale_by_complement_upperSW)) & + allocate(scale_by_complement_upperSW(nminor_absorber_intervals_upper)) + if (.not. allocated(rayl_upperSW)) & + allocate(rayl_upperSW(ngptsSW, nmixingfracs, ntemps)) + if (.not. allocated(rayl_lowerSW)) & + allocate(rayl_lowerSW(ngptsSW, nmixingfracs, ntemps)) + if (.not. allocated(solar_quietSW)) & + allocate(solar_quietSW(ngptsSW)) + if (.not. allocated(solar_facularSW)) & + allocate(solar_facularSW(ngptsSW)) + if (.not. allocated(solar_sunspotSW)) & + allocate(solar_sunspotSW(ngptsSW)) + if (.not. allocated(temp1)) & + allocate(temp1(nminor_absorber_intervals_lower)) + if (.not. allocated(temp2)) & + allocate(temp2(nminor_absorber_intervals_upper)) + if (.not. allocated(temp3)) & + allocate(temp3(nminor_absorber_intervals_lower)) + if (.not. allocated(temp4)) & + allocate(temp4(nminor_absorber_intervals_upper)) ! Read in fields from file if (mpirank==mpiroot) write (*,*) 'Reading RRTMGP shortwave k-distribution data ... ' status = nf90_inq_varid(ncid, 'gas_names', varID) - status = nf90_get_var( ncid, varID, gas_names) + status = nf90_get_var( ncid, varID, gas_namesSW) status = nf90_inq_varid(ncid, 'scaling_gas_lower', varID) - status = nf90_get_var( ncid, varID, scaling_gas_lower) + status = nf90_get_var( ncid, varID, scaling_gas_lowerSW) status = nf90_inq_varid(ncid, 'scaling_gas_upper', varID) - status = nf90_get_var( ncid, varID, scaling_gas_upper) + status = nf90_get_var( ncid, varID, scaling_gas_upperSW) status = nf90_inq_varid(ncid, 'gas_minor', varID) - status = nf90_get_var( ncid, varID, gas_minor) + status = nf90_get_var( ncid, varID, gas_minorSW) status = nf90_inq_varid(ncid, 'identifier_minor', varID) - status = nf90_get_var( ncid, varID, identifier_minor) + status = nf90_get_var( ncid, varID, identifier_minorSW) status = nf90_inq_varid(ncid, 'minor_gases_lower', varID) - status = nf90_get_var( ncid, varID, minor_gases_lower) + status = nf90_get_var( ncid, varID, minor_gases_lowerSW) status = nf90_inq_varid(ncid, 'minor_gases_upper', varID) - status = nf90_get_var( ncid, varID, minor_gases_upper) + status = nf90_get_var( ncid, varID, minor_gases_upperSW) status = nf90_inq_varid(ncid, 'minor_limits_gpt_lower', varID) - status = nf90_get_var( ncid, varID, minor_limits_gpt_lower) + status = nf90_get_var( ncid, varID, minor_limits_gpt_lowerSW) status = nf90_inq_varid(ncid, 'minor_limits_gpt_upper', varID) - status = nf90_get_var( ncid, varID, minor_limits_gpt_upper) + status = nf90_get_var( ncid, varID, minor_limits_gpt_upperSW) status = nf90_inq_varid(ncid, 'bnd_limits_gpt', varID) - status = nf90_get_var( ncid, varID, band2gpt) + status = nf90_get_var( ncid, varID, band2gptSW) status = nf90_inq_varid(ncid, 'key_species', varID) - status = nf90_get_var( ncid, varID, key_species) + status = nf90_get_var( ncid, varID, key_speciesSW) status = nf90_inq_varid(ncid,'bnd_limits_wavenumber', varID) - status = nf90_get_var( ncid, varID, band_lims) + status = nf90_get_var( ncid, varID, band_limsSW) status = nf90_inq_varid(ncid, 'press_ref', varID) - status = nf90_get_var( ncid, varID, press_ref) + status = nf90_get_var( ncid, varID, press_refSW) status = nf90_inq_varid(ncid, 'temp_ref', varID) - status = nf90_get_var( ncid, varID, temp_ref) + status = nf90_get_var( ncid, varID, temp_refSW) status = nf90_inq_varid(ncid, 'absorption_coefficient_ref_P', varID) - status = nf90_get_var( ncid, varID, temp_ref_p) + status = nf90_get_var( ncid, varID, temp_ref_pSW) status = nf90_inq_varid(ncid, 'absorption_coefficient_ref_T', varID) - status = nf90_get_var( ncid, varID, temp_ref_t) + status = nf90_get_var( ncid, varID, temp_ref_tSW) status = nf90_inq_varid(ncid, 'tsi_default', varID) - status = nf90_get_var( ncid, varID, tsi_default) + status = nf90_get_var( ncid, varID, tsi_defaultSW) status = nf90_inq_varid(ncid, 'mg_default', varID) - status = nf90_get_var( ncid, varID, mg_default) + status = nf90_get_var( ncid, varID, mg_defaultSW) status = nf90_inq_varid(ncid, 'sb_default', varID) - status = nf90_get_var( ncid, varID, sb_default) + status = nf90_get_var( ncid, varID, sb_defaultSW) status = nf90_inq_varid(ncid, 'press_ref_trop', varID) - status = nf90_get_var( ncid, varID, press_ref_trop) + status = nf90_get_var( ncid, varID, press_ref_tropSW) status = nf90_inq_varid(ncid, 'kminor_lower', varID) - status = nf90_get_var( ncid, varID, kminor_lower) + status = nf90_get_var( ncid, varID, kminor_lowerSW) status = nf90_inq_varid(ncid, 'kminor_upper', varID) - status = nf90_get_var( ncid, varID, kminor_upper) + status = nf90_get_var( ncid, varID, kminor_upperSW) status = nf90_inq_varid(ncid, 'vmr_ref', varID) - status = nf90_get_var( ncid, varID, vmr_ref) + status = nf90_get_var( ncid, varID, vmr_refSW) status = nf90_inq_varid(ncid, 'kmajor', varID) - status = nf90_get_var( ncid, varID, kmajor) + status = nf90_get_var( ncid, varID, kmajorSW) status = nf90_inq_varid(ncid, 'kminor_start_lower', varID) - status = nf90_get_var( ncid, varID, kminor_start_lower) + status = nf90_get_var( ncid, varID, kminor_start_lowerSW) status = nf90_inq_varid(ncid, 'kminor_start_upper', varID) - status = nf90_get_var( ncid, varID, kminor_start_upper) + status = nf90_get_var( ncid, varID, kminor_start_upperSW) status = nf90_inq_varid(ncid, 'solar_source_quiet', varID) - status = nf90_get_var( ncid, varID, solar_quiet) + status = nf90_get_var( ncid, varID, solar_quietSW) status = nf90_inq_varid(ncid, 'solar_source_facular', varID) - status = nf90_get_var( ncid, varID, solar_facular) + status = nf90_get_var( ncid, varID, solar_facularSW) status = nf90_inq_varid(ncid, 'solar_source_sunspot', varID) - status = nf90_get_var( ncid, varID, solar_sunspot) + status = nf90_get_var( ncid, varID, solar_sunspotSW) status = nf90_inq_varid(ncid, 'rayl_lower', varID) - status = nf90_get_var( ncid, varID, rayl_lower) + status = nf90_get_var( ncid, varID, rayl_lowerSW) status = nf90_inq_varid(ncid, 'rayl_upper', varID) - status = nf90_get_var( ncid, varID, rayl_upper) + status = nf90_get_var( ncid, varID, rayl_upperSW) ! Logical fields are read in as integers and then converted to logicals. status = nf90_inq_varid(ncid,'minor_scales_with_density_lower', varID) status = nf90_get_var( ncid, varID,temp1) - minor_scales_with_density_lower(:) = .false. - where(temp1 .eq. 1) minor_scales_with_density_lower(:) = .true. + minor_scales_with_density_lowerSW(:) = .false. + where(temp1 .eq. 1) minor_scales_with_density_lowerSW(:) = .true. status = nf90_inq_varid(ncid,'minor_scales_with_density_upper', varID) status = nf90_get_var( ncid, varID,temp2) - minor_scales_with_density_upper(:) = .false. - where(temp2 .eq. 1) minor_scales_with_density_upper(:) = .true. + minor_scales_with_density_upperSW(:) = .false. + where(temp2 .eq. 1) minor_scales_with_density_upperSW(:) = .true. status = nf90_inq_varid(ncid,'scale_by_complement_lower', varID) status = nf90_get_var( ncid, varID,temp3) - scale_by_complement_lower(:) = .false. - where(temp3 .eq. 1) scale_by_complement_lower(:) = .true. + scale_by_complement_lowerSW(:) = .false. + where(temp3 .eq. 1) scale_by_complement_lowerSW(:) = .true. status = nf90_inq_varid(ncid,'scale_by_complement_upper', varID) status = nf90_get_var( ncid, varID,temp4) - scale_by_complement_upper(:) = .false. - where(temp4 .eq. 1) scale_by_complement_upper(:) = .true. + scale_by_complement_upperSW(:) = .false. + where(temp4 .eq. 1) scale_by_complement_upperSW(:) = .true. ! Close status = nf90_close(ncid) ! endif - - ! Initialize gas concentrations and gas optics class - call check_error_msg('sw_gas_optics_init',gas_concentrations%init(active_gases_array)) - call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, gas_names, & - key_species, band2gpt, band_lims, press_ref, press_ref_trop, temp_ref, temp_ref_p, & - temp_ref_t, vmr_ref, kmajor, kminor_lower, kminor_upper, gas_minor, identifier_minor, & - minor_gases_lower, minor_gases_upper, minor_limits_gpt_lower,minor_limits_gpt_upper, & - minor_scales_with_density_lower, minor_scales_with_density_upper, scaling_gas_lower, & - scaling_gas_upper, scale_by_complement_lower, scale_by_complement_upper, & - kminor_start_lower, kminor_start_upper, solar_quiet, solar_facular, solar_sunspot, & - tsi_default, mg_default, sb_default, rayl_lower, rayl_upper)) + ! + ! Initialize RRTMGP DDT's... + ! + ! Shortwave k-distribution data +!$omp critical (load_sw_gas_optics) + call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, & + gas_namesSW, key_speciesSW, band2gptSW, band_limsSW, press_refSW, press_ref_tropSW,& + temp_refSW, temp_ref_pSW, temp_ref_tSW, vmr_refSW, kmajorSW, kminor_lowerSW, & + kminor_upperSW, gas_minorSW, identifier_minorSW, minor_gases_lowerSW, & + minor_gases_upperSW, minor_limits_gpt_lowerSW, minor_limits_gpt_upperSW, & + minor_scales_with_density_lowerSW, minor_scales_with_density_upperSW, & + scaling_gas_lowerSW, scaling_gas_upperSW, scale_by_complement_lowerSW, & + scale_by_complement_upperSW, kminor_start_lowerSW, kminor_start_upperSW, & + solar_quietSW, solar_facularSW, solar_sunspotSW, tsi_defaultSW, mg_defaultSW, & + sb_defaultSW, rayl_lowerSW, rayl_upperSW)) +!$omp end critical (load_sw_gas_optics) end subroutine rrtmgp_sw_gas_optics_init @@ -291,21 +326,20 @@ end subroutine rrtmgp_sw_gas_optics_init !! \section arg_table_rrtmgp_sw_gas_optics_run !! \htmlinclude rrtmgp_sw_gas_optics.html !! - subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, nday, idxday, sw_gas_props, p_lay,& - p_lev, toa_src_sw, t_lay, t_lev, gas_concentrations, solcon, rrtmgp_nGases, & - active_gases_array, sw_optical_props_clrsky, errmsg, errflg) + subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, ngptsGPsw, nday, idxday, p_lay, & + p_lev, toa_src_sw, t_lay, t_lev, gas_concentrations, solcon, sw_optical_props_clrsky,& + errmsg, errflg) ! Inputs logical, intent(in) :: & doSWrad ! Flag to calculate SW irradiances integer,intent(in) :: & + ngptsGPsw, & ! Number of spectral (g) points. nDay, & ! Number of daylit points. nCol, & ! Number of horizontal points nLev ! Number of vertical levels integer,intent(in),dimension(ncol) :: & idxday ! Indices for daylit points. - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT: spectral information for RRTMGP SW radiation scheme real(kind_phys), dimension(ncol,nLev), intent(in) :: & p_lay, & ! Pressure @ model layer-centers (hPa) t_lay ! Temperature (K) @@ -316,10 +350,6 @@ subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, nday, idxday, sw_gas_pr gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) real(kind_phys), intent(in) :: & solcon ! Solar constant - integer, intent(in) :: & - rrtmgp_nGases ! Number of trace gases active in RRTMGP - character(len=*),dimension(rrtmgp_nGases), intent(in) :: & - active_gases_array ! Character array containing trace gases to include in RRTMGP ! Output character(len=*), intent(out) :: & @@ -328,15 +358,14 @@ subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, nday, idxday, sw_gas_pr errflg ! CCPP error code type(ty_optical_props_2str),intent(out) :: & sw_optical_props_clrsky ! RRTMGP DDT: clear-sky shortwave optical properties, spectral (tau,ssa,g) - real(kind_phys), dimension(ncol,sw_gas_props%get_ngpt()), intent(out) :: & + real(kind_phys), dimension(nCol,ngptsGPsw), intent(out) :: & toa_src_sw ! TOA incident spectral flux (W/m2) - + character(len=32), dimension(gas_concentrations%get_num_gases()) :: active_gases ! Local variables integer :: ij,iGas real(kind_phys), dimension(ncol,nLev) :: vmrTemp - real(kind_phys), dimension(nday,sw_gas_props%get_ngpt()) :: toa_src_sw_temp - type(ty_gas_concs) :: & - gas_concentrations_daylit ! RRTMGP DDT: trace gas concentrations (vmr) + real(kind_phys), dimension(nday,ngptsGPsw) :: toa_src_sw_temp + type(ty_gas_concs) :: gas_concentrations_daylit ! Initialize CCPP error handling variables errmsg = '' @@ -344,38 +373,39 @@ subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, nday, idxday, sw_gas_pr if (.not. doSWrad) return + toa_src_sw(:,:) = 0._kind_phys if (nDay .gt. 0) then + active_gases = gas_concentrations%get_gas_names() ! Allocate space - call check_error_msg('rrtmgp_sw_gas_optics_run',sw_optical_props_clrsky%alloc_2str(nday, nLev, sw_gas_props)) + call check_error_msg('rrtmgp_sw_gas_optics_run_alloc_2str',& + sw_optical_props_clrsky%alloc_2str(nday, nLev, sw_gas_props)) + call check_error_msg('rrtmgp_sw_gas_optics_run_init_ty_gas_concs', & + gas_concentrations_daylit%init(active_gases)) - ! Initialize gas concentrations and gas optics class - call check_error_msg('rrtmgp_sw_rte_run',gas_concentrations_daylit%init(active_gases_array)) - - ! Subset the gas concentrations, only need daylit points. - do iGas=1,rrtmgp_nGases - call check_error_msg('rrtmgp_sw_rte_run',& - gas_concentrations%get_vmr(trim(active_gases_array(iGas)),vmrTemp)) - call check_error_msg('rrtmgp_sw_rte_run',& - gas_concentrations_daylit%set_vmr(trim(active_gases_array(iGas)),vmrTemp(idxday(1:nday),:))) + ! Subset the gas concentrations. + do iGas=1,gas_concentrations%get_num_gases() + call check_error_msg('rrtmgp_sw_gas_optics_run_get_vmr',& + gas_concentrations%get_vmr(trim(active_gases(iGas)),vmrTemp)) + call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& + gas_concentrations_daylit%set_vmr(trim(active_gases(iGas)),vmrTemp(idxday(1:nday),:))) enddo - ! Gas-optics + ! Call SW gas-optics call check_error_msg('rrtmgp_sw_gas_optics_run',sw_gas_props%gas_optics(& - p_lay(idxday(1:nday),:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(idxday(1:nday),:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(idxday(1:nday),:), & ! IN - Temperature @ layer-centers (K) - gas_concentrations_daylit, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by - ! spectral point (tau,ssa,g) - toa_src_sw_temp)) ! OUT - TOA incident shortwave radiation (spectral) + p_lay(idxday(1:nday),:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(idxday(1:nday),:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(idxday(1:nday),:), & ! IN - Temperature @ layer-centers (K) + gas_concentrations_daylit, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + sw_optical_props_clrsky, & ! OUT - RRTMGP DDT: Shortwave optical properties, by + ! spectral point (tau,ssa,g) + toa_src_sw_temp)) ! OUT - TOA incident shortwave radiation (spectral) toa_src_sw(idxday(1:nday),:) = toa_src_sw_temp + ! Scale incident flux do ij=1,nday toa_src_sw(idxday(ij),:) = toa_src_sw(idxday(ij),:)*solcon/ & sum(toa_src_sw(idxday(ij),:)) enddo - else - toa_src_sw(:,:) = 0. endif end subroutine rrtmgp_sw_gas_optics_run diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta index 75bcde0c8..e69b68d73 100644 --- a/physics/rrtmgp_sw_gas_optics.meta +++ b/physics/rrtmgp_sw_gas_optics.meta @@ -8,6 +8,30 @@ [ccpp-arg-table] name = rrtmgp_sw_gas_optics_init type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[nLev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[nThreads] + standard_name = omp_threads + long_name = number of OpenMP threads available to scheme + units = count + dimensions = () + type = integer + intent = in + optional = F [rrtmgp_root_dir] standard_name = directory_for_rte_rrtmgp_source_code long_name = directory for rte+rrtmgp source code @@ -26,21 +50,12 @@ intent = in optional = F kind = len=128 -[rrtmgp_nGases] - standard_name = number_of_active_gases_used_by_RRTMGP - long_name = number of gases available used by RRTMGP - units = count - dimensions = () - type = integer - intent = in - optional = F -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* +[gas_concentrations] + standard_name = Gas_concentrations_for_RRTMGP_suite + long_name = DDT containing gas concentrations for RRTMGP radiation scheme + units = DDT + dimensions = () + type = ty_gas_concs intent = in optional = F [mpirank] @@ -84,14 +99,6 @@ type = integer intent = out optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = out - optional = F ######################################################################## [ccpp-arg-table] @@ -137,12 +144,12 @@ type = integer intent = in optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp +[ngptsGPsw] + standard_name = number_of_sw_spectral_points_rrtmgp + long_name = number of spectral points in RRTMGP SW calculation + units = count + dimensions = () + type = integer intent = in optional = F [p_lay] @@ -207,23 +214,6 @@ kind = kind_phys intent = in optional = F -[rrtmgp_nGases] - standard_name = number_of_active_gases_used_by_RRTMGP - long_name = number of gases available used by RRTMGP - units = count - dimensions = () - type = integer - intent = in - optional = F -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index 9719c6e86..c3bee1829 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -9,7 +9,7 @@ module rrtmgp_sw_rte use mo_fluxes_byband, only: ty_fluxes_byband use module_radsw_parameters, only: cmpfsw_type use rrtmgp_aux, only: check_error_msg - + use rrtmgp_sw_gas_optics, only: sw_gas_props implicit none public rrtmgp_sw_rte_init, rrtmgp_sw_rte_run, rrtmgp_sw_rte_finalize @@ -29,7 +29,7 @@ end subroutine rrtmgp_sw_rte_init !! \htmlinclude rrtmgp_sw_rte.html !! subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay, & - t_lay, p_lev, sw_gas_props, sw_optical_props_clrsky, sfc_alb_nir_dir, sfc_alb_nir_dif,& + t_lay, p_lev, sw_optical_props_clrsky, sfc_alb_nir_dir, sfc_alb_nir_dif,& sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clouds, & sw_optical_props_aerosol, rrtmgp_nGases, active_gases_array, scmpsw, fluxswUP_allsky, & fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) @@ -51,8 +51,6 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz t_lay ! Temperature (K) real(kind_phys), dimension(ncol,NLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (Pa) - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT: SW spectral information type(ty_optical_props_2str),intent(inout) :: & sw_optical_props_clrsky ! RRTMGP DDT: shortwave clear-sky radiative properties type(ty_optical_props_2str),intent(in) :: & diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index 43febcd92..f5bf59ade 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -92,14 +92,6 @@ kind = kind_phys intent = in optional = F -[sw_gas_props] - standard_name = coefficients_for_sw_gas_optics - long_name = DDT containing spectral information for RRTMGP SW radiation scheme - units = DDT - dimensions = () - type = ty_gas_optics_rrtmgp - intent = in - optional = F [sw_optical_props_clrsky] standard_name = shortwave_optical_properties_for_clear_sky long_name = Fortran DDT containing RRTMGP optical properties From ab9d45b53de63ff854bd40bc3edb784affbd8ce3 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 11 Feb 2021 18:16:33 +0000 Subject: [PATCH 02/12] Working on multiple threads. --- physics/GFS_rrtmgp_pre.F90 | 64 ++++++++++--------------------- physics/GFS_rrtmgp_pre.meta | 8 ---- physics/rrtmgp_lw_gas_optics.F90 | 8 ++-- physics/rrtmgp_lw_gas_optics.meta | 2 +- physics/rrtmgp_sw_gas_optics.F90 | 40 +++++++++++-------- physics/rrtmgp_sw_gas_optics.meta | 2 +- physics/rrtmgp_sw_rte.F90 | 10 ++--- physics/rrtmgp_sw_rte.meta | 17 -------- 8 files changed, 53 insertions(+), 98 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index eb5ae91ce..75e285ac6 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -21,6 +21,8 @@ module GFS_rrtmgp_pre ! Save trace gas indices. integer :: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, iStr_o2, iStr_ccl4, & iStr_cfc11, iStr_cfc12, iStr_cfc22 + character(len=32),dimension(:),allocatable :: & + active_gases_array public GFS_rrtmgp_pre_run,GFS_rrtmgp_pre_init,GFS_rrtmgp_pre_finalize contains @@ -31,25 +33,22 @@ module GFS_rrtmgp_pre !! \section arg_table_GFS_rrtmgp_pre_init !! \htmlinclude GFS_rrtmgp_pre_init.html !! - subroutine GFS_rrtmgp_pre_init(nGases, active_gases, gas_concentrations, errmsg, errflg) + subroutine GFS_rrtmgp_pre_init(nGases, active_gases, errmsg, errflg) ! Inputs integer, intent(in) :: & - nGases ! Number of active gases in RRTMGP + nGases ! Number of active gases in RRTMGP character(len=*), intent(in) :: & active_gases ! List of active gases from namelist. ! Outputs - type(ty_gas_concs),intent(out) :: & - gas_concentrations ! RRTMGP DDT: gas volumne mixing ratios character(len=*), intent(out) :: & - errmsg ! Error message + errmsg ! Error message integer, intent(out) :: & - errflg ! Error flag + errflg ! Error flag ! Local variables character(len=1) :: tempstr integer :: ij, count integer,dimension(nGases,2) :: gasIndices - character(len=32),dimension(nGases) :: active_gases_array ! Initialize errmsg = '' @@ -74,6 +73,7 @@ subroutine GFS_rrtmgp_pre_init(nGases, active_gases, gas_concentrations, errmsg gasIndices(nGases,2)=len(trim(active_gases)) ! Now extract the gas names + allocate(active_gases_array(nGases)) do ij=1,nGases active_gases_array(ij) = active_gases(gasIndices(ij,1):gasIndices(ij,2)) if(trim(active_gases_array(ij)) .eq. 'h2o') istr_h2o = ij @@ -88,22 +88,6 @@ subroutine GFS_rrtmgp_pre_init(nGases, active_gases, gas_concentrations, errmsg if(trim(active_gases_array(ij)) .eq. 'cfc22') istr_cfc22 = ij enddo - ! Initialze RRTMGP DDTs - call check_error_msg('GFS_rrtmgp_pre_init', & - gas_concentrations%init( active_gases_array)) - call check_error_msg('GFS_rrtmgp_pre_setvmr_h2o',& - gas_concentrations%set_vmr(active_gases_array(iStr_o2), 0._kind_phys)) - call check_error_msg('GFS_rrtmgp_pre_setvmr_co2',& - gas_concentrations%set_vmr(active_gases_array(iStr_co2), 0._kind_phys)) - call check_error_msg('GFS_rrtmgp_pre_setvmr_ch4',& - gas_concentrations%set_vmr(active_gases_array(iStr_ch4), 0._kind_phys)) - call check_error_msg('GFS_rrtmgp_pre_setvmr_n2o',& - gas_concentrations%set_vmr(active_gases_array(iStr_n2o), 0._kind_phys)) - call check_error_msg('GFS_rrtmgp_pre_setvmr_h2o',& - gas_concentrations%set_vmr(active_gases_array(iStr_h2o), 0._kind_phys)) - call check_error_msg('GFS_rrtmgp_pre_setvmr_o3', & - gas_concentrations%set_vmr(active_gases_array(iStr_o3), 0._kind_phys)) - end subroutine GFS_rrtmgp_pre_init ! ######################################################################################### @@ -112,11 +96,10 @@ end subroutine GFS_rrtmgp_pre_init !> \section arg_table_GFS_rrtmgp_pre_run !! \htmlinclude GFS_rrtmgp_pre_run.html !! - subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, & - fhlwr, xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, con_eps,& - con_epsm1, con_fvirt, con_epsqs, minGPpres, & - raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, tv_lay, relhum, tracer,& - gas_concentrations, errmsg, errflg) + subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & + xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, con_eps, con_epsm1, con_fvirt, & + con_epsqs, minGPpres, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, & + tv_lay, relhum, tracer, gas_concentrations, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -299,22 +282,15 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, vmr_h2o = merge((q_lay/(1-q_lay))*amdw, 0., q_lay .ne. 1.) vmr_o3 = merge(o3_lay*amdo3, 0., o3_lay .gt. 0.) - ! Initialize and populate RRTMGP DDT w/ gas-concentrations - active_gases = gas_concentrations%get_gas_names() - do iGas=1,gas_concentrations%get_num_gases() - if (iGas .eq. istr_o2) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_o2', & - gas_concentrations%set_vmr(trim(active_gases(iGas)), gas_vmr(:,:,4))) - if (iGas .eq. istr_co2) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_co2',& - gas_concentrations%set_vmr(trim(active_gases(iGas)), gas_vmr(:,:,1))) - if (iGas .eq. istr_ch4) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_ch4',& - gas_concentrations%set_vmr(trim(active_gases(iGas)), gas_vmr(:,:,3))) - if (iGas .eq. istr_n2o) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_n2o',& - gas_concentrations%set_vmr(trim(active_gases(iGas)), gas_vmr(:,:,2))) - if (iGas .eq. istr_h2o) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_h2o',& - gas_concentrations%set_vmr(trim(active_gases(iGas)), vmr_h2o)) - if (iGas .eq. istr_o3) call check_error_msg('GFS_rrtmgp_pre_run_setvmr_o3', & - gas_concentrations%set_vmr(trim(active_gases(iGas)), vmr_o3)) - enddo + ! Populate RRTMGP DDT w/ gas-concentrations + gas_concentrations%gas_name(:) = active_gases_array(:) + gas_concentrations%concs(istr_o2)%conc(:,:) = gas_vmr(:,:,4) + gas_concentrations%concs(istr_co2)%conc(:,:) = gas_vmr(:,:,1) + gas_concentrations%concs(istr_ch4)%conc(:,:) = gas_vmr(:,:,3) + gas_concentrations%concs(istr_n2o)%conc(:,:) = gas_vmr(:,:,2) + gas_concentrations%concs(istr_h2o)%conc(:,:) = vmr_h2o(:,:) + gas_concentrations%concs(istr_o3)%conc(:,:) = vmr_o3(:,:) + ! ####################################################################################### ! Radiation time step (output) (Is this really needed?) (Used by some diagnostics) ! ####################################################################################### diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 28487974b..521d7a8a0 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -25,14 +25,6 @@ type = integer intent = in optional = F -[gas_concentrations] - standard_name = Gas_concentrations_for_RRTMGP_suite - long_name = DDT containing gas concentrations for RRTMGP radiation scheme - units = DDT - dimensions = () - type = ty_gas_concs - intent = out - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index df2021864..1455814f4 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -7,6 +7,7 @@ module rrtmgp_lw_gas_optics use mo_optical_props, only: ty_optical_props_1scl use mo_compute_bc, only: compute_bc use rrtmgp_aux, only: check_error_msg + use GFS_rrtmgp_pre, only: active_gases_array use netcdf implicit none @@ -70,7 +71,7 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_co nCol, nLev, mpicomm, mpirank, mpiroot, minGPpres, errmsg, errflg) ! Inputs - type(ty_gas_concs), intent(in) :: & + type(ty_gas_concs), intent(inout) :: & gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory @@ -266,6 +267,7 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_co ! !$omp critical (load_lw_gas_optics) ! Longwave k-distribution data. + gas_concentrations%gas_name(:) = active_gases_array(:) call check_error_msg('rrtmgp_lw_gas_optics_init',lw_gas_props%load(gas_concentrations, & gas_namesLW, key_speciesLW, band2gptLW, band_limsLW, press_refLW, press_ref_tropLW,& temp_refLW, temp_ref_pLW, temp_ref_tLW, vmr_refLW, kmajorLW, kminor_lowerLW, & @@ -289,8 +291,8 @@ end subroutine rrtmgp_lw_gas_optics_init !! \section arg_table_rrtmgp_lw_gas_optics_run !! \htmlinclude rrtmgp_lw_gas_optics_run.html !! - subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, p_lay, p_lev, t_lay,& - t_lev, tsfg, gas_concentrations, lw_optical_props_clrsky, sources, errmsg, errflg) + subroutine rrtmgp_lw_gas_optics_run(doLWrad, nCol, nLev, p_lay, p_lev, t_lay, t_lev, tsfg,& + gas_concentrations, lw_optical_props_clrsky, sources, errmsg, errflg) ! Inputs logical, intent(in) :: & diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index f256858d9..6a2fea449 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -32,7 +32,7 @@ units = DDT dimensions = () type = ty_gas_concs - intent = in + intent = inout optional = F [ncol] standard_name = horizontal_loop_extent diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 668582d87..7075147b1 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -7,9 +7,11 @@ module rrtmgp_sw_gas_optics use rrtmgp_aux, only: check_error_msg use mo_optical_props, only: ty_optical_props_2str use mo_compute_bc, only: compute_bc + use GFS_rrtmgp_pre, only: active_gases_array use netcdf implicit none + ! RRTMGP k-distribution LUTs. type(ty_gas_optics_rrtmgp) :: sw_gas_props integer, dimension(:), allocatable :: & @@ -69,8 +71,8 @@ module rrtmgp_sw_gas_optics !! \section arg_table_rrtmgp_sw_gas_optics_init !! \htmlinclude rrtmgp_sw_gas_optics.html !! - subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, rrtmgp_sw_file_gas, gas_concentrations, & - mpicomm, mpirank, mpiroot, errmsg, errflg) + subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, & + rrtmgp_sw_file_gas, gas_concentrations, mpicomm, mpirank, mpiroot, errmsg, errflg) ! Inputs character(len=128),intent(in) :: & @@ -83,7 +85,7 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, rrtm mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank - type(ty_gas_concs),intent(in) :: & + type(ty_gas_concs),intent(inout) :: & gas_concentrations ! RRTMGP DDT containing active trace gases. ! Outputs @@ -92,15 +94,11 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, rrtm integer, intent(out) :: & errflg ! CCPP error code - ! Dimensions - integer :: & - ntemps, npress, ngptsSW, nabsorbers, nextrabsorbers, & - nminorabsorbers, nmixingfracs, nlayers, nbnds, npairs, & - nminor_absorber_intervals_lower, nminor_absorber_intervals_upper, & - ncontributors_lower, ncontributors_upper - ! Local variables - integer :: status, ncid, dimid, varID, iGas + integer :: status, ncid, dimid, varID, iGas, ntemps, npress, ngptsSW, nabsorbers, & + nextrabsorbers, nminorabsorbers, nmixingfracs, nlayers, nbnds, npairs, & + nminor_absorber_intervals_lower, nminor_absorber_intervals_upper, & + ncontributors_lower, ncontributors_upper integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: sw_gas_props_file @@ -306,6 +304,7 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, rrtm ! ! Shortwave k-distribution data !$omp critical (load_sw_gas_optics) + gas_concentrations%gas_name(:) = active_gases_array(:) call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, & gas_namesSW, key_speciesSW, band2gptSW, band_limsSW, press_refSW, press_ref_tropSW,& temp_refSW, temp_ref_pSW, temp_ref_tSW, vmr_refSW, kmajorSW, kminor_lowerSW, & @@ -360,7 +359,7 @@ subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, ngptsGPsw, nday, idxday sw_optical_props_clrsky ! RRTMGP DDT: clear-sky shortwave optical properties, spectral (tau,ssa,g) real(kind_phys), dimension(nCol,ngptsGPsw), intent(out) :: & toa_src_sw ! TOA incident spectral flux (W/m2) - character(len=32), dimension(gas_concentrations%get_num_gases()) :: active_gases + ! Local variables integer :: ij,iGas real(kind_phys), dimension(ncol,nLev) :: vmrTemp @@ -375,19 +374,26 @@ subroutine rrtmgp_sw_gas_optics_run(doSWrad, nCol, nLev, ngptsGPsw, nday, idxday toa_src_sw(:,:) = 0._kind_phys if (nDay .gt. 0) then - active_gases = gas_concentrations%get_gas_names() + !active_gases = gas_concentrations%get_gas_names() ! Allocate space call check_error_msg('rrtmgp_sw_gas_optics_run_alloc_2str',& sw_optical_props_clrsky%alloc_2str(nday, nLev, sw_gas_props)) - call check_error_msg('rrtmgp_sw_gas_optics_run_init_ty_gas_concs', & - gas_concentrations_daylit%init(active_gases)) + + gas_concentrations_daylit%ncol = nDay + gas_concentrations_daylit%nlay = nLev + allocate(gas_concentrations_daylit%gas_name(gas_concentrations%get_num_gases())) + allocate(gas_concentrations_daylit%concs(gas_concentrations%get_num_gases())) + do iGas=1,gas_concentrations%get_num_gases() + allocate(gas_concentrations_daylit%concs(iGas)%conc(nDay, nLev)) + enddo + gas_concentrations_daylit%gas_name(:) = active_gases_array(:) ! Subset the gas concentrations. do iGas=1,gas_concentrations%get_num_gases() call check_error_msg('rrtmgp_sw_gas_optics_run_get_vmr',& - gas_concentrations%get_vmr(trim(active_gases(iGas)),vmrTemp)) + gas_concentrations%get_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp)) call check_error_msg('rrtmgp_sw_gas_optics_run_set_vmr',& - gas_concentrations_daylit%set_vmr(trim(active_gases(iGas)),vmrTemp(idxday(1:nday),:))) + gas_concentrations_daylit%set_vmr(trim(gas_concentrations_daylit%gas_name(iGas)),vmrTemp(idxday(1:nday),:))) enddo ! Call SW gas-optics diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta index e69b68d73..17d0b046b 100644 --- a/physics/rrtmgp_sw_gas_optics.meta +++ b/physics/rrtmgp_sw_gas_optics.meta @@ -56,7 +56,7 @@ units = DDT dimensions = () type = ty_gas_concs - intent = in + intent = inout optional = F [mpirank] standard_name = mpi_rank diff --git a/physics/rrtmgp_sw_rte.F90 b/physics/rrtmgp_sw_rte.F90 index c3bee1829..4ea4c36d8 100644 --- a/physics/rrtmgp_sw_rte.F90 +++ b/physics/rrtmgp_sw_rte.F90 @@ -29,10 +29,10 @@ end subroutine rrtmgp_sw_rte_init !! \htmlinclude rrtmgp_sw_rte.html !! subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, coszen, p_lay, & - t_lay, p_lev, sw_optical_props_clrsky, sfc_alb_nir_dir, sfc_alb_nir_dif,& + t_lay, p_lev, sw_optical_props_clrsky, sfc_alb_nir_dir, sfc_alb_nir_dif, & sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, toa_src_sw, sw_optical_props_clouds, & - sw_optical_props_aerosol, rrtmgp_nGases, active_gases_array, scmpsw, fluxswUP_allsky, & - fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, errmsg, errflg) + sw_optical_props_aerosol, scmpsw, fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky,& + fluxswDOWN_clrsky, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -63,10 +63,6 @@ subroutine rrtmgp_sw_rte_run(doSWrad, doSWclrsky, nCol, nLev, nDay, idxday, cosz sfc_alb_uvvis_dif ! Surface albedo (diffuse) real(kind_phys), dimension(ncol,sw_gas_props%get_ngpt()), intent(in) :: & toa_src_sw ! TOA incident spectral flux (W/m2) - integer, intent(in) :: & - rrtmgp_nGases ! Number of trace gases active in RRTMGP - character(len=*),dimension(rrtmgp_nGases), intent(in) :: & - active_gases_array ! Character array containing trace gases to include in RRTMGP ! Outputs character(len=*), intent(out) :: & diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index f5bf59ade..0558819f1 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -161,23 +161,6 @@ kind = kind_phys intent = in optional = F -[rrtmgp_nGases] - standard_name = number_of_active_gases_used_by_RRTMGP - long_name = number of gases available used by RRTMGP - units = count - dimensions = () - type = integer - intent = in - optional = F -[active_gases_array] - standard_name = list_of_active_gases_used_by_RRTMGP - long_name = list of active gases used by RRTMGP - units = none - dimensions = (number_of_active_gases_used_by_RRTMGP) - type = character - kind = len=* - intent = in - optional = F [scmpsw] standard_name = components_of_surface_downward_shortwave_fluxes long_name = derived type for special components of surface downward shortwave fluxes From 7fe6ab42fa86812222a94a58ab5a014ff5e5846b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 16 Feb 2021 18:32:18 +0000 Subject: [PATCH 03/12] Define interstitial for minimum temperature allowed by GP. --- physics/GFS_rrtmgp_pre.F90 | 11 ++++++----- physics/GFS_rrtmgp_pre.meta | 9 +++++++++ physics/rrtmgp_lw_gas_optics.F90 | 4 +++- physics/rrtmgp_lw_gas_optics.meta | 9 +++++++++ 4 files changed, 27 insertions(+), 6 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 9fc12963d..220248231 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -98,8 +98,8 @@ end subroutine GFS_rrtmgp_pre_init !! subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, con_eps, con_epsm1, con_fvirt, & - con_epsqs, minGPpres, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, qs_lay, q_lay, & - tv_lay, relhum, tracer, gas_concentrations, errmsg, errflg) + con_epsqs, minGPpres, minGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, & + qs_lay, q_lay, tv_lay, relhum, tracer, gas_concentrations, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -111,7 +111,8 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, f lsswr, & ! Call SW radiation? lslwr ! Call LW radiation real(kind_phys), intent(in) :: & - minGPpres, & ! Minimum pressure allowed in RRTMGP + minGPtemp, & ! Minimum temperature allowed in RRTMGP. + minGPpres, & ! Minimum pressure allowed in RRTMGP. fhswr, & ! Frequency of SW radiation call. fhlwr ! Frequency of LW radiation call. real(kind_phys), intent(in) :: & @@ -204,8 +205,8 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, f ! Bound temperature at layer centers. do iCol=1,NCOL do iLay=1,nLev - if (t_lay(iCol,iLay) .le. lw_gas_props%get_temp_min()) then - t_lay = lw_gas_props%get_temp_min() + epsilon(lw_gas_props%get_temp_min()) + if (t_lay(iCol,iLay) .le. minGPtemp) then + t_lay = minGPtemp + epsilon(minGPtemp) endif enddo enddo diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 521d7a8a0..cb53b8f86 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -230,6 +230,15 @@ kind = kind_phys intent = in optional = F +[minGPtemp] + standard_name = minimum_temperature_in_RRTMGP + long_name = minimum temperature allowed in RRTMGP + units = K + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F [raddt] standard_name = time_step_for_radiation long_name = radiation time step diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index 1455814f4..e2a24cea1 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -68,7 +68,7 @@ module rrtmgp_lw_gas_optics !! \htmlinclude rrtmgp_lw_gas_optics_init.html !! subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_concentrations,& - nCol, nLev, mpicomm, mpirank, mpiroot, minGPpres, errmsg, errflg) + nCol, nLev, mpicomm, mpirank, mpiroot, minGPpres, minGPtemp, errmsg, errflg) ! Inputs type(ty_gas_concs), intent(inout) :: & @@ -89,6 +89,7 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_co integer, intent(out) :: & errflg ! CCPP error code real(kind_phys), intent(out) :: & + minGPtemp, & ! Minimum temperature allowed by RRTMGP. minGPpres ! Minimum pressure allowed by RRTMGP. ! Dimensions integer :: & @@ -282,6 +283,7 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_co ! The minimum pressure allowed in GP RTE calculations. Used to bound uppermost layer ! temperature (GFS_rrtmgp_pre.F90) minGPpres = lw_gas_props%get_press_min() + minGPtemp = lw_gas_props%get_temp_min() end subroutine rrtmgp_lw_gas_optics_init diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index 6a2fea449..c6eb3d145 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -100,6 +100,15 @@ kind = kind_phys intent = out optional = F +[minGPtemp] + standard_name = minimum_temperature_in_RRTMGP + long_name = minimum temperature allowed in RRTMGP + units = K + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F ######################################################################## [ccpp-arg-table] From 1ba6619a25ae9938c1dc1e3b9ccfa5de71b31bd8 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 17 Feb 2021 18:12:00 +0000 Subject: [PATCH 04/12] MPI broadcast working in sw gas optics init. Error later in _run routine when referencing. --- physics/rrtmgp_sw_gas_optics.F90 | 160 +++++++++++++++++++++++++++++-- 1 file changed, 151 insertions(+), 9 deletions(-) diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 7075147b1..99c7c38a0 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -9,6 +9,9 @@ module rrtmgp_sw_gas_optics use mo_compute_bc, only: compute_bc use GFS_rrtmgp_pre, only: active_gases_array use netcdf +#ifdef MPI + use mpi +#endif implicit none @@ -98,19 +101,31 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, integer :: status, ncid, dimid, varID, iGas, ntemps, npress, ngptsSW, nabsorbers, & nextrabsorbers, nminorabsorbers, nmixingfracs, nlayers, nbnds, npairs, & nminor_absorber_intervals_lower, nminor_absorber_intervals_upper, & - ncontributors_lower, ncontributors_upper + ncontributors_lower, ncontributors_upper, mpierr integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: sw_gas_props_file + ! Variables to create structured MPI data type + integer, parameter :: & + nVars = 35 ! Number of fields in DDT + integer,dimension(nVars) :: & + displacement_array, blocklength_array, type_array + integer :: & + base, iVar + ! Initialize errmsg = '' errflg = 0 - ! Filenames are set in the gphysics_nml + ! Filenames are set in the gfphysics_nml sw_gas_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_sw_file_gas) - ! Read dimensions for k-distribution fields (only on master processor(0)) -! if (mpirank .eq. mpiroot) then + ! Read dimensions for k-distribution fields. + ! Only on master processor(0), if MPI enabled. +#ifdef MPI + call mpi_barrier(mpicomm, mpierr) + if (mpirank .eq. mpiroot) then +#endif ! Open file status = nf90_open(trim(sw_gas_props_file), NF90_NOWRITE, ncid) @@ -143,8 +158,8 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, status = nf90_inquire_dimension(ncid, dimid, len=nminor_absorber_intervals_lower) status = nf90_inq_dimid(ncid, 'minor_absorber_intervals_upper', dimid) status = nf90_inquire_dimension(ncid, dimid, len=nminor_absorber_intervals_upper) - - ! Allocate space for arrays + + ! Allocate space for arrays (all processors) if (.not. allocated(gas_namesSW)) & allocate(gas_namesSW(nabsorbers)) if (.not. allocated(scaling_gas_lowerSW)) & @@ -212,7 +227,7 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, if (.not. allocated(temp4)) & allocate(temp4(nminor_absorber_intervals_upper)) - ! Read in fields from file + ! Read in files ... if (mpirank==mpiroot) write (*,*) 'Reading RRTMGP shortwave k-distribution data ... ' status = nf90_inq_varid(ncid, 'gas_names', varID) status = nf90_get_var( ncid, varID, gas_namesSW) @@ -297,12 +312,139 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! Close status = nf90_close(ncid) -! endif + if (mpirank==mpiroot) write (*,*) ' complete' + + ! Broadcast data to other processors... +#ifdef MPI + if (mpirank==mpiroot) write (*,*) 'MPI Broadcasting RRTMGP shortwave k-distribution data ... ' + + ! Real scalars + call mpi_bcast(press_ref_tropSW, & + 1, MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_1',mpierr) + call mpi_bcast(temp_ref_pSW, & + 1, MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_2',mpierr) + call mpi_bcast(temp_ref_tSW, & + 1, MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_3',mpierr) + call mpi_bcast(tsi_defaultSW, & + 1, MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_4',mpierr) + call mpi_bcast(mg_defaultSW, & + 1, MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_5',mpierr) + call mpi_bcast(sb_defaultSW, & + 1, MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_6',mpierr) + + ! Integer arrays + call mpi_bcast(kminor_start_lowerSW, & + size(kminor_start_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_7',mpierr) + call mpi_bcast(kminor_start_upperSW, & + size(kminor_start_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_8',mpierr) + call mpi_bcast(band2gptSW, & + size(band2gptSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_9',mpierr) + call mpi_bcast(minor_limits_gpt_lowerSW, & + size(minor_limits_gpt_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_10',mpierr) + call mpi_bcast(minor_limits_gpt_upperSW, & + size(minor_limits_gpt_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_11',mpierr) + call mpi_bcast(key_speciesSW, & + size(key_speciesSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_12',mpierr) + + ! Real arrays + call mpi_bcast(press_refSW, & + size(press_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_13',mpierr) + call mpi_bcast(temp_refSW, & + size(temp_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_14',mpierr) + call mpi_bcast(solar_quietSW, & + size(solar_quietSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_15',mpierr) + call mpi_bcast(solar_facularSW, & + size(solar_facularSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_16',mpierr) + call mpi_bcast(solar_sunspotSW, & + size(solar_sunspotSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_17',mpierr) + call mpi_bcast(band_limsSW, & + size(band_limsSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_18',mpierr) + call mpi_bcast(vmr_refSW, & + size(vmr_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_19',mpierr) + call mpi_bcast(kminor_lowerSW, & + size(kminor_lowerSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_20',mpierr) + call mpi_bcast(kminor_upperSW, & + size(kminor_upperSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_21',mpierr) + call mpi_bcast(rayl_lowerSW, & + size(rayl_lowerSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_22',mpierr) + call mpi_bcast(rayl_upperSW, & + size(rayl_upperSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_23',mpierr) + call mpi_bcast(kmajorSW, & + size(kmajorSW), MPI_REAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_24',mpierr) + + ! Characters + call mpi_bcast(gas_namesSW, & + size(gas_namesSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_25',mpierr) + call mpi_bcast(gas_minorSW, & + size(gas_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_26',mpierr) + call mpi_bcast(identifier_minorSW, & + size(identifier_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_27',mpierr) + call mpi_bcast(minor_gases_lowerSW, & + size(minor_gases_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_28',mpierr) + call mpi_bcast(minor_gases_upperSW, & + size(minor_gases_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_29',mpierr) + call mpi_bcast(scaling_gas_lowerSW, & + size(scaling_gas_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_30',mpierr) + call mpi_bcast(scaling_gas_upperSW, & + size(scaling_gas_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_31',mpierr) + + ! Logicals + call mpi_bcast(minor_scales_with_density_lowerSW, & + size(minor_scales_with_density_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_32',mpierr) + call mpi_bcast(minor_scales_with_density_upperSW, & + size(minor_scales_with_density_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_33',mpierr) + call mpi_bcast(scale_by_complement_lowerSW, & + size(scale_by_complement_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_34',mpierr) + call mpi_bcast(scale_by_complement_upperSW, & + size(scale_by_complement_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call check_error_msg('sw_gas_optics_mpi_bcast_35',mpierr) + + ! + if (mpirank==mpiroot) write (*,*) ' complete' + endif + ! All other processors wait for master to finish the broadcast... + write (*,*) ' process waiting... ',mpirank + call mpi_barrier(mpicomm, mpierr) + write (*,*) ' master process complete ',mpirank +#endif ! ! Initialize RRTMGP DDT's... ! - ! Shortwave k-distribution data !$omp critical (load_sw_gas_optics) gas_concentrations%gas_name(:) = active_gases_array(:) call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, & From 7cb5d21aa6c7479cb7e29e5f016575353f9d2461 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 17 Feb 2021 18:23:22 +0000 Subject: [PATCH 05/12] Removed error checking calls. --- physics/rrtmgp_sw_gas_optics.F90 | 45 +------------------------------- 1 file changed, 1 insertion(+), 44 deletions(-) diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 99c7c38a0..9402f8e5d 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -105,14 +105,6 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: sw_gas_props_file - ! Variables to create structured MPI data type - integer, parameter :: & - nVars = 35 ! Number of fields in DDT - integer,dimension(nVars) :: & - displacement_array, blocklength_array, type_array - integer :: & - base, iVar - ! Initialize errmsg = '' errflg = 0 @@ -159,7 +151,7 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, status = nf90_inq_dimid(ncid, 'minor_absorber_intervals_upper', dimid) status = nf90_inquire_dimension(ncid, dimid, len=nminor_absorber_intervals_upper) - ! Allocate space for arrays (all processors) + ! Allocate space for arrays if (.not. allocated(gas_namesSW)) & allocate(gas_namesSW(nabsorbers)) if (.not. allocated(scaling_gas_lowerSW)) & @@ -321,117 +313,82 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! Real scalars call mpi_bcast(press_ref_tropSW, & 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_1',mpierr) call mpi_bcast(temp_ref_pSW, & 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_2',mpierr) call mpi_bcast(temp_ref_tSW, & 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_3',mpierr) call mpi_bcast(tsi_defaultSW, & 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_4',mpierr) call mpi_bcast(mg_defaultSW, & 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_5',mpierr) call mpi_bcast(sb_defaultSW, & 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_6',mpierr) ! Integer arrays call mpi_bcast(kminor_start_lowerSW, & size(kminor_start_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_7',mpierr) call mpi_bcast(kminor_start_upperSW, & size(kminor_start_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_8',mpierr) call mpi_bcast(band2gptSW, & size(band2gptSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_9',mpierr) call mpi_bcast(minor_limits_gpt_lowerSW, & size(minor_limits_gpt_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_10',mpierr) call mpi_bcast(minor_limits_gpt_upperSW, & size(minor_limits_gpt_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_11',mpierr) call mpi_bcast(key_speciesSW, & size(key_speciesSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_12',mpierr) ! Real arrays call mpi_bcast(press_refSW, & size(press_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_13',mpierr) call mpi_bcast(temp_refSW, & size(temp_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_14',mpierr) call mpi_bcast(solar_quietSW, & size(solar_quietSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_15',mpierr) call mpi_bcast(solar_facularSW, & size(solar_facularSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_16',mpierr) call mpi_bcast(solar_sunspotSW, & size(solar_sunspotSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_17',mpierr) call mpi_bcast(band_limsSW, & size(band_limsSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_18',mpierr) call mpi_bcast(vmr_refSW, & size(vmr_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_19',mpierr) call mpi_bcast(kminor_lowerSW, & size(kminor_lowerSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_20',mpierr) call mpi_bcast(kminor_upperSW, & size(kminor_upperSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_21',mpierr) call mpi_bcast(rayl_lowerSW, & size(rayl_lowerSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_22',mpierr) call mpi_bcast(rayl_upperSW, & size(rayl_upperSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_23',mpierr) call mpi_bcast(kmajorSW, & size(kmajorSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_24',mpierr) ! Characters call mpi_bcast(gas_namesSW, & size(gas_namesSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_25',mpierr) call mpi_bcast(gas_minorSW, & size(gas_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_26',mpierr) call mpi_bcast(identifier_minorSW, & size(identifier_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_27',mpierr) call mpi_bcast(minor_gases_lowerSW, & size(minor_gases_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_28',mpierr) call mpi_bcast(minor_gases_upperSW, & size(minor_gases_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_29',mpierr) call mpi_bcast(scaling_gas_lowerSW, & size(scaling_gas_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_30',mpierr) call mpi_bcast(scaling_gas_upperSW, & size(scaling_gas_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_31',mpierr) ! Logicals call mpi_bcast(minor_scales_with_density_lowerSW, & size(minor_scales_with_density_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_32',mpierr) call mpi_bcast(minor_scales_with_density_upperSW, & size(minor_scales_with_density_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_33',mpierr) call mpi_bcast(scale_by_complement_lowerSW, & size(scale_by_complement_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_34',mpierr) call mpi_bcast(scale_by_complement_upperSW, & size(scale_by_complement_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - call check_error_msg('sw_gas_optics_mpi_bcast_35',mpierr) ! if (mpirank==mpiroot) write (*,*) ' complete' From f3e963ff23a01427b8841cc00476de3d26a7dd03 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 17 Feb 2021 21:38:31 +0000 Subject: [PATCH 06/12] Making progress. Not all fields being broadcast correctly. --- physics/rrtmgp_sw_gas_optics.F90 | 411 +++++++++++++++++-------------- 1 file changed, 232 insertions(+), 179 deletions(-) diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 9402f8e5d..6bc0f1e16 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -17,6 +17,10 @@ module rrtmgp_sw_gas_optics ! RRTMGP k-distribution LUTs. type(ty_gas_optics_rrtmgp) :: sw_gas_props + integer :: & + ntempsSW, npressSW, ngptsSW, nabsorbersSW, nextrabsorbersSW, nminorabsorbersSW, & + nmixingfracsSW, nlayersSW, nbndsSW, npairsSW, nminor_absorber_intervals_lowerSW,& + nminor_absorber_intervals_upperSW, ncontributors_lowerSW, ncontributors_upperSW integer, dimension(:), allocatable :: & kminor_start_lowerSW, & ! Starting index in the [1, nContributors] vector for a contributor ! given by \"minor_gases_lower\" (lower atmosphere) @@ -98,10 +102,7 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, errflg ! CCPP error code ! Local variables - integer :: status, ncid, dimid, varID, iGas, ntemps, npress, ngptsSW, nabsorbers, & - nextrabsorbers, nminorabsorbers, nmixingfracs, nlayers, nbnds, npairs, & - nminor_absorber_intervals_lower, nminor_absorber_intervals_upper, & - ncontributors_lower, ncontributors_upper, mpierr + integer :: status, ncid, dimid, varID, iGas, mpierr integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: sw_gas_props_file @@ -112,115 +113,164 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! Filenames are set in the gfphysics_nml sw_gas_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_sw_file_gas) - ! Read dimensions for k-distribution fields. - ! Only on master processor(0), if MPI enabled. + ! ####################################################################################### + ! + ! Read dimensions for k-distribution fields... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### #ifdef MPI - call mpi_barrier(mpicomm, mpierr) if (mpirank .eq. mpiroot) then #endif + write (*,*) 'Reading RRTMGP shortwave k-distribution metadata ... ' + ! Open file status = nf90_open(trim(sw_gas_props_file), NF90_NOWRITE, ncid) ! Read dimensions for k-distribution fields status = nf90_inq_dimid(ncid, 'temperature', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=ntemps) + status = nf90_inquire_dimension(ncid, dimid, len=ntempsSW) status = nf90_inq_dimid(ncid, 'pressure', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=npress) + status = nf90_inquire_dimension(ncid, dimid, len=npressSW) status = nf90_inq_dimid(ncid, 'absorber', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nabsorbers) + status = nf90_inquire_dimension(ncid, dimid, len=nabsorbersSW) status = nf90_inq_dimid(ncid, 'minor_absorber',dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nminorabsorbers) + status = nf90_inquire_dimension(ncid, dimid, len=nminorabsorbersSW) status = nf90_inq_dimid(ncid, 'absorber_ext', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nextrabsorbers) + status = nf90_inquire_dimension(ncid, dimid, len=nextrabsorbersSW) status = nf90_inq_dimid(ncid, 'mixing_fraction', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nmixingfracs) + status = nf90_inquire_dimension(ncid, dimid, len=nmixingfracsSW) status = nf90_inq_dimid(ncid, 'atmos_layer', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nlayers) + status = nf90_inquire_dimension(ncid, dimid, len=nlayersSW) status = nf90_inq_dimid(ncid, 'bnd', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nbnds) + status = nf90_inquire_dimension(ncid, dimid, len=nbndsSW) status = nf90_inq_dimid(ncid, 'gpt', dimid) status = nf90_inquire_dimension(ncid, dimid, len=ngptsSW) status = nf90_inq_dimid(ncid, 'pair', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=npairs) + status = nf90_inquire_dimension(ncid, dimid, len=npairsSW) status = nf90_inq_dimid(ncid, 'contributors_lower',dimid) - status = nf90_inquire_dimension(ncid, dimid, len=ncontributors_lower) + status = nf90_inquire_dimension(ncid, dimid, len=ncontributors_lowerSW) status = nf90_inq_dimid(ncid, 'contributors_upper', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=ncontributors_upper) + status = nf90_inquire_dimension(ncid, dimid, len=ncontributors_upperSW) status = nf90_inq_dimid(ncid, 'minor_absorber_intervals_lower', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nminor_absorber_intervals_lower) + status = nf90_inquire_dimension(ncid, dimid, len=nminor_absorber_intervals_lowerSW) status = nf90_inq_dimid(ncid, 'minor_absorber_intervals_upper', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nminor_absorber_intervals_upper) - - ! Allocate space for arrays - if (.not. allocated(gas_namesSW)) & - allocate(gas_namesSW(nabsorbers)) - if (.not. allocated(scaling_gas_lowerSW)) & - allocate(scaling_gas_lowerSW(nminor_absorber_intervals_lower)) - if (.not. allocated(scaling_gas_upperSW)) & - allocate(scaling_gas_upperSW(nminor_absorber_intervals_upper)) - if (.not. allocated(gas_minorSW)) & - allocate(gas_minorSW(nminorabsorbers)) - if (.not. allocated(identifier_minorSW)) & - allocate(identifier_minorSW(nminorabsorbers)) - if (.not. allocated(minor_gases_lowerSW)) & - allocate(minor_gases_lowerSW(nminor_absorber_intervals_lower)) - if (.not. allocated(minor_gases_upperSW)) & - allocate(minor_gases_upperSW(nminor_absorber_intervals_upper)) - if (.not. allocated(minor_limits_gpt_lowerSW)) & - allocate(minor_limits_gpt_lowerSW(npairs,nminor_absorber_intervals_lower)) - if (.not. allocated(minor_limits_gpt_upperSW)) & - allocate(minor_limits_gpt_upperSW(npairs,nminor_absorber_intervals_upper)) - if (.not. allocated(band2gptSW)) & - allocate(band2gptSW(2,nbnds)) - if (.not. allocated(key_speciesSW)) & - allocate(key_speciesSW(2,nlayers,nbnds)) - if (.not. allocated(band_limsSW)) & - allocate(band_limsSW(2,nbnds)) - if (.not. allocated(press_refSW)) & - allocate(press_refSW(npress)) - if (.not. allocated(temp_refSW)) & - allocate(temp_refSW(ntemps)) - if (.not. allocated(vmr_refSW)) & - allocate(vmr_refSW(nlayers, nextrabsorbers, ntemps)) - if (.not. allocated(kminor_lowerSW)) & - allocate(kminor_lowerSW(ncontributors_lower, nmixingfracs, ntemps)) - if (.not. allocated(kmajorSW)) & - allocate(kmajorSW(ngptsSW, nmixingfracs, npress+1, ntemps)) - if (.not. allocated(kminor_start_lowerSW)) & - allocate(kminor_start_lowerSW(nminor_absorber_intervals_lower)) - if (.not. allocated(kminor_upperSW)) & - allocate(kminor_upperSW(ncontributors_upper, nmixingfracs, ntemps)) - if (.not. allocated(kminor_start_upperSW)) & - allocate(kminor_start_upperSW(nminor_absorber_intervals_upper)) - if (.not. allocated(minor_scales_with_density_lowerSW)) & - allocate(minor_scales_with_density_lowerSW(nminor_absorber_intervals_lower)) - if (.not. allocated(minor_scales_with_density_upperSW)) & - allocate(minor_scales_with_density_upperSW(nminor_absorber_intervals_upper)) - if (.not. allocated(scale_by_complement_lowerSW)) & - allocate(scale_by_complement_lowerSW(nminor_absorber_intervals_lower)) - if (.not. allocated(scale_by_complement_upperSW)) & - allocate(scale_by_complement_upperSW(nminor_absorber_intervals_upper)) - if (.not. allocated(rayl_upperSW)) & - allocate(rayl_upperSW(ngptsSW, nmixingfracs, ntemps)) - if (.not. allocated(rayl_lowerSW)) & - allocate(rayl_lowerSW(ngptsSW, nmixingfracs, ntemps)) - if (.not. allocated(solar_quietSW)) & - allocate(solar_quietSW(ngptsSW)) - if (.not. allocated(solar_facularSW)) & - allocate(solar_facularSW(ngptsSW)) - if (.not. allocated(solar_sunspotSW)) & - allocate(solar_sunspotSW(ngptsSW)) - if (.not. allocated(temp1)) & - allocate(temp1(nminor_absorber_intervals_lower)) - if (.not. allocated(temp2)) & - allocate(temp2(nminor_absorber_intervals_upper)) - if (.not. allocated(temp3)) & - allocate(temp3(nminor_absorber_intervals_lower)) - if (.not. allocated(temp4)) & - allocate(temp4(nminor_absorber_intervals_upper)) - - ! Read in files ... - if (mpirank==mpiroot) write (*,*) 'Reading RRTMGP shortwave k-distribution data ... ' + status = nf90_inquire_dimension(ncid, dimid, len=nminor_absorber_intervals_upperSW) + +#ifdef MPI + endif ! On master processor + + ! Other processors waiting... + write (*,*) ' process waiting... ',mpirank + call mpi_barrier(mpicomm, mpierr) + + ! ####################################################################################### + ! + ! Broadcast dimensions... + ! (ALL processors) + ! + ! ####################################################################################### + call mpi_bcast(nbndsSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(ngptsSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nmixingfracsSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(ntempsSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(npressSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nabsorbersSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nextrabsorbersSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nminorabsorbersSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nlayersSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(npairsSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(ncontributors_upperSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(ncontributors_lowerSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nminor_absorber_intervals_upperSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nminor_absorber_intervals_lowerSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) +#endif + + ! ####################################################################################### + ! + ! Allocate space for arrays... + ! (ALL processors) + ! + ! ####################################################################################### + write (*,*) 'Allocating RRTMGP shortwave k-distribution data ... ' + if (.not. allocated(gas_namesSW)) & + allocate(gas_namesSW(nabsorbersSW)) + if (.not. allocated(scaling_gas_lowerSW)) & + allocate(scaling_gas_lowerSW(nminor_absorber_intervals_lowerSW)) + if (.not. allocated(scaling_gas_upperSW)) & + allocate(scaling_gas_upperSW(nminor_absorber_intervals_upperSW)) + if (.not. allocated(gas_minorSW)) & + allocate(gas_minorSW(nminorabsorbersSW)) + if (.not. allocated(identifier_minorSW)) & + allocate(identifier_minorSW(nminorabsorbersSW)) + if (.not. allocated(minor_gases_lowerSW)) & + allocate(minor_gases_lowerSW(nminor_absorber_intervals_lowerSW)) + if (.not. allocated(minor_gases_upperSW)) & + allocate(minor_gases_upperSW(nminor_absorber_intervals_upperSW)) + if (.not. allocated(minor_limits_gpt_lowerSW)) & + allocate(minor_limits_gpt_lowerSW(npairsSW,nminor_absorber_intervals_lowerSW)) + if (.not. allocated(minor_limits_gpt_upperSW)) & + allocate(minor_limits_gpt_upperSW(npairsSW,nminor_absorber_intervals_upperSW)) + if (.not. allocated(band2gptSW)) & + allocate(band2gptSW(2,nbndsSW)) + if (.not. allocated(key_speciesSW)) & + allocate(key_speciesSW(2,nlayersSW,nbndsSW)) + if (.not. allocated(band_limsSW)) & + allocate(band_limsSW(2,nbndsSW)) + if (.not. allocated(press_refSW)) & + allocate(press_refSW(npressSW)) + if (.not. allocated(temp_refSW)) & + allocate(temp_refSW(ntempsSW)) + if (.not. allocated(vmr_refSW)) & + allocate(vmr_refSW(nlayersSW, nextrabsorbersSW, ntempsSW)) + if (.not. allocated(kminor_lowerSW)) & + allocate(kminor_lowerSW(ncontributors_lowerSW, nmixingfracsSW, ntempsSW)) + if (.not. allocated(kmajorSW)) & + allocate(kmajorSW(ngptsSW, nmixingfracsSW, npressSW+1, ntempsSW)) + if (.not. allocated(kminor_start_lowerSW)) & + allocate(kminor_start_lowerSW(nminor_absorber_intervals_lowerSW)) + if (.not. allocated(kminor_upperSW)) & + allocate(kminor_upperSW(ncontributors_upperSW, nmixingfracsSW, ntempsSW)) + if (.not. allocated(kminor_start_upperSW)) & + allocate(kminor_start_upperSW(nminor_absorber_intervals_upperSW)) + if (.not. allocated(minor_scales_with_density_lowerSW)) & + allocate(minor_scales_with_density_lowerSW(nminor_absorber_intervals_lowerSW)) + if (.not. allocated(minor_scales_with_density_upperSW)) & + allocate(minor_scales_with_density_upperSW(nminor_absorber_intervals_upperSW)) + if (.not. allocated(scale_by_complement_lowerSW)) & + allocate(scale_by_complement_lowerSW(nminor_absorber_intervals_lowerSW)) + if (.not. allocated(scale_by_complement_upperSW)) & + allocate(scale_by_complement_upperSW(nminor_absorber_intervals_upperSW)) + if (.not. allocated(rayl_upperSW)) & + allocate(rayl_upperSW(ngptsSW, nmixingfracsSW, ntempsSW)) + if (.not. allocated(rayl_lowerSW)) & + allocate(rayl_lowerSW(ngptsSW, nmixingfracsSW, ntempsSW)) + if (.not. allocated(solar_quietSW)) & + allocate(solar_quietSW(ngptsSW)) + if (.not. allocated(solar_facularSW)) & + allocate(solar_facularSW(ngptsSW)) + if (.not. allocated(solar_sunspotSW)) & + allocate(solar_sunspotSW(ngptsSW)) + if (.not. allocated(temp1)) & + allocate(temp1(nminor_absorber_intervals_lowerSW)) + if (.not. allocated(temp2)) & + allocate(temp2(nminor_absorber_intervals_upperSW)) + if (.not. allocated(temp3)) & + allocate(temp3(nminor_absorber_intervals_lowerSW)) + if (.not. allocated(temp4)) & + allocate(temp4(nminor_absorber_intervals_upperSW)) + + ! ####################################################################################### + ! + ! Read in data ... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### +#ifdef MPI + call mpi_barrier(mpicomm, mpierr) + if (mpirank .eq. mpiroot) then +#endif + write (*,*) 'Reading RRTMGP shortwave k-distribution data ... ' status = nf90_inq_varid(ncid, 'gas_names', varID) status = nf90_get_var( ncid, varID, gas_namesSW) status = nf90_inq_varid(ncid, 'scaling_gas_lower', varID) @@ -306,102 +356,105 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, status = nf90_close(ncid) if (mpirank==mpiroot) write (*,*) ' complete' - ! Broadcast data to other processors... #ifdef MPI - if (mpirank==mpiroot) write (*,*) 'MPI Broadcasting RRTMGP shortwave k-distribution data ... ' - - ! Real scalars - call mpi_bcast(press_ref_tropSW, & - 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(temp_ref_pSW, & - 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(temp_ref_tSW, & - 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(tsi_defaultSW, & - 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(mg_defaultSW, & - 1, MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(sb_defaultSW, & - 1, MPI_REAL, mpiroot, mpicomm, mpierr) - - ! Integer arrays - call mpi_bcast(kminor_start_lowerSW, & - size(kminor_start_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_bcast(kminor_start_upperSW, & - size(kminor_start_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_bcast(band2gptSW, & - size(band2gptSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_bcast(minor_limits_gpt_lowerSW, & - size(minor_limits_gpt_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_bcast(minor_limits_gpt_upperSW, & - size(minor_limits_gpt_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_bcast(key_speciesSW, & - size(key_speciesSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) - - ! Real arrays - call mpi_bcast(press_refSW, & - size(press_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(temp_refSW, & - size(temp_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(solar_quietSW, & - size(solar_quietSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(solar_facularSW, & - size(solar_facularSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(solar_sunspotSW, & - size(solar_sunspotSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(band_limsSW, & - size(band_limsSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(vmr_refSW, & - size(vmr_refSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(kminor_lowerSW, & - size(kminor_lowerSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(kminor_upperSW, & - size(kminor_upperSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(rayl_lowerSW, & - size(rayl_lowerSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(rayl_upperSW, & - size(rayl_upperSW), MPI_REAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(kmajorSW, & - size(kmajorSW), MPI_REAL, mpiroot, mpicomm, mpierr) - - ! Characters - call mpi_bcast(gas_namesSW, & - size(gas_namesSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(gas_minorSW, & - size(gas_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(identifier_minorSW, & - size(identifier_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(minor_gases_lowerSW, & - size(minor_gases_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(minor_gases_upperSW, & - size(minor_gases_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(scaling_gas_lowerSW, & - size(scaling_gas_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(scaling_gas_upperSW, & - size(scaling_gas_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - - ! Logicals - call mpi_bcast(minor_scales_with_density_lowerSW, & - size(minor_scales_with_density_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(minor_scales_with_density_upperSW, & - size(minor_scales_with_density_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(scale_by_complement_lowerSW, & - size(scale_by_complement_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - call mpi_bcast(scale_by_complement_upperSW, & - size(scale_by_complement_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - - ! - if (mpirank==mpiroot) write (*,*) ' complete' - endif - ! All other processors wait for master to finish the broadcast... + endif ! Master process + + ! Other processors waiting... write (*,*) ' process waiting... ',mpirank call mpi_barrier(mpicomm, mpierr) - write (*,*) ' master process complete ',mpirank + + ! ####################################################################################### + ! + ! Broadcast data... + ! (ALL processors) + ! + ! ####################################################################################### + write (*,*) 'MPI Broadcasting RRTMGP shortwave k-distribution data ... ' + + ! Real scalars + call mpi_bcast(press_ref_tropSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(temp_ref_pSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(temp_ref_tSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(tsi_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(mg_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(sb_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + + ! Integer arrays + call mpi_bcast(kminor_start_lowerSW, & + size(kminor_start_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(kminor_start_upperSW, & + size(kminor_start_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(band2gptSW, & + size(band2gptSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(minor_limits_gpt_lowerSW, & + size(minor_limits_gpt_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(minor_limits_gpt_upperSW, & + size(minor_limits_gpt_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(key_speciesSW, & + size(key_speciesSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + + ! Real arrays + call mpi_bcast(press_refSW, & + size(press_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(temp_refSW, & + size(temp_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(solar_quietSW, & + size(solar_quietSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(solar_facularSW, & + size(solar_facularSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(solar_sunspotSW, & + size(solar_sunspotSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(band_limsSW, & + size(band_limsSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(vmr_refSW, & + size(vmr_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(kminor_lowerSW, & + size(kminor_lowerSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(kminor_upperSW, & + size(kminor_upperSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(rayl_lowerSW, & + size(rayl_lowerSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(rayl_upperSW, & + size(rayl_upperSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(kmajorSW, & + size(kmajorSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + + ! Characters + call mpi_bcast(gas_namesSW, & + size(gas_namesSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(gas_minorSW, & + size(gas_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(identifier_minorSW, & + size(identifier_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(minor_gases_lowerSW, & + size(minor_gases_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(minor_gases_upperSW, & + size(minor_gases_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(scaling_gas_lowerSW, & + size(scaling_gas_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(scaling_gas_upperSW, & + size(scaling_gas_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + + ! Logicals + call mpi_bcast(minor_scales_with_density_lowerSW, & + size(minor_scales_with_density_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call mpi_bcast(minor_scales_with_density_upperSW, & + size(minor_scales_with_density_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call mpi_bcast(scale_by_complement_lowerSW, & + size(scale_by_complement_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call mpi_bcast(scale_by_complement_upperSW, & + size(scale_by_complement_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + + write (*,*) ' broadcasting complete' + call mpi_barrier(mpicomm, mpierr) #endif + ! ####################################################################################### ! ! Initialize RRTMGP DDT's... ! + ! ####################################################################################### + print*,'gas_minorSW: ',gas_minorSW !$omp critical (load_sw_gas_optics) gas_concentrations%gas_name(:) = active_gases_array(:) call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, & From 994166afc28b49808bf5e4602651cca03a0b4943 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 17 Feb 2021 23:33:28 +0000 Subject: [PATCH 07/12] MPI Broadcast working in SW gas-optics. --- physics/rrtmgp_sw_gas_optics.F90 | 102 +++++++++++++++---------------- 1 file changed, 51 insertions(+), 51 deletions(-) diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 6bc0f1e16..2d8afdc14 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -102,7 +102,7 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, errflg ! CCPP error code ! Local variables - integer :: status, ncid, dimid, varID, iGas, mpierr + integer :: status, ncid, dimid, varID, iGas, mpierr, iChar integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4 character(len=264) :: sw_gas_props_file @@ -161,7 +161,6 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, endif ! On master processor ! Other processors waiting... - write (*,*) ' process waiting... ',mpirank call mpi_barrier(mpicomm, mpierr) ! ####################################################################################### @@ -192,7 +191,6 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! (ALL processors) ! ! ####################################################################################### - write (*,*) 'Allocating RRTMGP shortwave k-distribution data ... ' if (.not. allocated(gas_namesSW)) & allocate(gas_namesSW(nabsorbersSW)) if (.not. allocated(scaling_gas_lowerSW)) & @@ -354,13 +352,10 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! Close status = nf90_close(ncid) - if (mpirank==mpiroot) write (*,*) ' complete' - #ifdef MPI endif ! Master process ! Other processors waiting... - write (*,*) ' process waiting... ',mpirank call mpi_barrier(mpicomm, mpierr) ! ####################################################################################### @@ -369,83 +364,89 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! (ALL processors) ! ! ####################################################################################### - write (*,*) 'MPI Broadcasting RRTMGP shortwave k-distribution data ... ' ! Real scalars - call mpi_bcast(press_ref_tropSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call mpi_bcast(temp_ref_pSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call mpi_bcast(temp_ref_tSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call mpi_bcast(tsi_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call mpi_bcast(mg_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call mpi_bcast(sb_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(press_ref_tropSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(temp_ref_pSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(temp_ref_tSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(tsi_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(mg_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(sb_defaultSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) ! Integer arrays call mpi_bcast(kminor_start_lowerSW, & - size(kminor_start_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + size(kminor_start_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) call mpi_bcast(kminor_start_upperSW, & - size(kminor_start_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + size(kminor_start_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) call mpi_bcast(band2gptSW, & - size(band2gptSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + size(band2gptSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) call mpi_bcast(minor_limits_gpt_lowerSW, & - size(minor_limits_gpt_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + size(minor_limits_gpt_lowerSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) call mpi_bcast(minor_limits_gpt_upperSW, & - size(minor_limits_gpt_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + size(minor_limits_gpt_upperSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) call mpi_bcast(key_speciesSW, & - size(key_speciesSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + size(key_speciesSW), MPI_INTEGER, mpiroot, mpicomm, mpierr) ! Real arrays call mpi_bcast(press_refSW, & - size(press_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(press_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(temp_refSW, & - size(temp_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(temp_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(solar_quietSW, & - size(solar_quietSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(solar_quietSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(solar_facularSW, & - size(solar_facularSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(solar_facularSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(solar_sunspotSW, & - size(solar_sunspotSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(solar_sunspotSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(band_limsSW, & - size(band_limsSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(band_limsSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(vmr_refSW, & - size(vmr_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(vmr_refSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(kminor_lowerSW, & - size(kminor_lowerSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(kminor_lowerSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(kminor_upperSW, & - size(kminor_upperSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(kminor_upperSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(rayl_lowerSW, & - size(rayl_lowerSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(rayl_lowerSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(rayl_upperSW, & - size(rayl_upperSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(rayl_upperSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(kmajorSW, & - size(kmajorSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + size(kmajorSW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) ! Characters - call mpi_bcast(gas_namesSW, & - size(gas_namesSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(gas_minorSW, & - size(gas_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(identifier_minorSW, & - size(identifier_minorSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(minor_gases_lowerSW, & - size(minor_gases_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(minor_gases_upperSW, & - size(minor_gases_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(scaling_gas_lowerSW, & - size(scaling_gas_lowerSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) - call mpi_bcast(scaling_gas_upperSW, & - size(scaling_gas_upperSW), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + do iChar=1,nabsorbersSW + call mpi_bcast(gas_namesSW(iChar), & + len(gas_namesSW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + enddo + do iChar=1,nminorabsorbersSW + call mpi_bcast(gas_minorSW(iChar), & + len(gas_minorSW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(identifier_minorSW(iChar), & + len(identifier_minorSW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + enddo + do iChar=1,nminor_absorber_intervals_lowerSW + call mpi_bcast(minor_gases_lowerSW(iChar), & + len(minor_gases_lowerSW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(scaling_gas_lowerSW(iChar), & + len(scaling_gas_lowerSW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + enddo + do iChar=1,nminor_absorber_intervals_upperSW + call mpi_bcast(minor_gases_upperSW(iChar), & + len(minor_gases_upperSW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(scaling_gas_upperSW(iChar), & + len(scaling_gas_upperSW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + enddo ! Logicals call mpi_bcast(minor_scales_with_density_lowerSW, & - size(minor_scales_with_density_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + size(minor_scales_with_density_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) call mpi_bcast(minor_scales_with_density_upperSW, & - size(minor_scales_with_density_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + size(minor_scales_with_density_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) call mpi_bcast(scale_by_complement_lowerSW, & - size(scale_by_complement_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + size(scale_by_complement_lowerSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) call mpi_bcast(scale_by_complement_upperSW, & - size(scale_by_complement_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + size(scale_by_complement_upperSW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) - write (*,*) ' broadcasting complete' call mpi_barrier(mpicomm, mpierr) #endif @@ -454,7 +455,6 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! Initialize RRTMGP DDT's... ! ! ####################################################################################### - print*,'gas_minorSW: ',gas_minorSW !$omp critical (load_sw_gas_optics) gas_concentrations%gas_name(:) = active_gases_array(:) call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, & From 0586868ced9de18f2f8ba7df9a4a35c03e06ce5b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 18 Feb 2021 16:41:12 +0000 Subject: [PATCH 08/12] MPI broadcast working in LW gas-optics initialization. --- physics/rrtmgp_lw_gas_optics.F90 | 320 +++++++++++++++++++++++------- physics/rrtmgp_lw_gas_optics.meta | 16 -- 2 files changed, 247 insertions(+), 89 deletions(-) diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index e2a24cea1..536adaaef 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -9,9 +9,18 @@ module rrtmgp_lw_gas_optics use rrtmgp_aux, only: check_error_msg use GFS_rrtmgp_pre, only: active_gases_array use netcdf +#ifdef MPI + use mpi +#endif + implicit none type(ty_gas_optics_rrtmgp) :: lw_gas_props + integer :: & + ntempsLW, npressLW, ngptsLW, nabsorbersLW, nextrabsorbersLW, nminorabsorbersLW,& + nmixingfracsLW, nlayersLW, nbndsLW, npairsLW, ninternalSourcetempsLW, & + nminor_absorber_intervals_lowerLW, nminor_absorber_intervals_upperLW, & + ncontributors_lowerLW, ncontributors_upperLW, nfit_coeffsLW integer, dimension(:), allocatable :: & kminor_start_lowerLW, & ! Starting index in the [1, nContributors] vector for a contributor ! given by \"minor_gases_lower\" (lower atmosphere) @@ -67,8 +76,8 @@ module rrtmgp_lw_gas_optics !! \section arg_table_rrtmgp_lw_gas_optics_init !! \htmlinclude rrtmgp_lw_gas_optics_init.html !! - subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_concentrations,& - nCol, nLev, mpicomm, mpirank, mpiroot, minGPpres, minGPtemp, errmsg, errflg) + subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, & + gas_concentrations, mpicomm, mpirank, mpiroot, minGPpres, minGPtemp, errmsg, errflg) ! Inputs type(ty_gas_concs), intent(inout) :: & @@ -77,29 +86,21 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_co rrtmgp_root_dir, & ! RTE-RRTMGP root directory rrtmgp_lw_file_gas ! RRTMGP file containing coefficients used to compute gaseous optical properties integer,intent(in) :: & - nCol, & ! Number of horizontal points - nLev, & ! Number of vertical levels mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank ! Outputs character(len=*), intent(out) :: & - errmsg ! CCPP error message + errmsg ! CCPP error message integer, intent(out) :: & - errflg ! CCPP error code + errflg ! CCPP error code real(kind_phys), intent(out) :: & - minGPtemp, & ! Minimum temperature allowed by RRTMGP. - minGPpres ! Minimum pressure allowed by RRTMGP. - ! Dimensions - integer :: & - ntemps, npress, ngpts, nabsorbers, nextrabsorbers, nminorabsorbers,& - nmixingfracs, nlayers, nbnds, npairs, ninternalSourcetemps, & - nminor_absorber_intervals_lower, nminor_absorber_intervals_upper, & - ncontributors_lower, ncontributors_upper,nfit_coeffs + minGPtemp, & ! Minimum temperature allowed by RRTMGP. + minGPpres ! Minimum pressure allowed by RRTMGP. ! Local variables - integer :: ncid, dimID, varID, status, iGas, ierr, ii + integer :: ncid, dimID, varID, status, iGas, ierr, ii, mpierr, iChar integer,dimension(:),allocatable :: temp1, temp2, temp3, temp4, & temp_log_array1, temp_log_array2, temp_log_array3, temp_log_array4 character(len=264) :: lw_gas_props_file @@ -111,80 +112,158 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_co ! Filenames are set in the physics_nml lw_gas_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_lw_file_gas) - ! On master processor only... -! if (mpirank .eq. mpiroot) then + ! ####################################################################################### + ! + ! Read dimensions for k-distribution fields... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + write (*,*) 'Reading RRTMGP longwave k-distribution metadata ... ' + ! Open file status = nf90_open(trim(lw_gas_props_file), NF90_NOWRITE, ncid) ! Read dimensions for k-distribution fields status = nf90_inq_dimid(ncid, 'temperature', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = ntemps) + status = nf90_inquire_dimension(ncid, dimid, len = ntempsLW) status = nf90_inq_dimid(ncid, 'pressure', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = npress) + status = nf90_inquire_dimension(ncid, dimid, len = npressLW) status = nf90_inq_dimid(ncid, 'absorber', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nabsorbers) + status = nf90_inquire_dimension(ncid, dimid, len = nabsorbersLW) status = nf90_inq_dimid(ncid, 'minor_absorber', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nminorabsorbers) + status = nf90_inquire_dimension(ncid, dimid, len = nminorabsorbersLW) status = nf90_inq_dimid(ncid, 'absorber_ext', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nextrabsorbers) + status = nf90_inquire_dimension(ncid, dimid, len = nextrabsorbersLW) status = nf90_inq_dimid(ncid, 'mixing_fraction', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nmixingfracs) + status = nf90_inquire_dimension(ncid, dimid, len = nmixingfracsLW) status = nf90_inq_dimid(ncid, 'atmos_layer', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nlayers) + status = nf90_inquire_dimension(ncid, dimid, len = nlayersLW) status = nf90_inq_dimid(ncid, 'bnd', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nbnds) + status = nf90_inquire_dimension(ncid, dimid, len = nbndsLW) status = nf90_inq_dimid(ncid, 'gpt', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = ngpts) + status = nf90_inquire_dimension(ncid, dimid, len = ngptsLW) status = nf90_inq_dimid(ncid, 'pair', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = npairs) + status = nf90_inquire_dimension(ncid, dimid, len = npairsLW) status = nf90_inq_dimid(ncid, 'contributors_lower', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = ncontributors_lower) + status = nf90_inquire_dimension(ncid, dimid, len = ncontributors_lowerLW) status = nf90_inq_dimid(ncid, 'contributors_upper', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = ncontributors_upper) + status = nf90_inquire_dimension(ncid, dimid, len = ncontributors_upperLW) status = nf90_inq_dimid(ncid, 'fit_coeffs', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nfit_coeffs) + status = nf90_inquire_dimension(ncid, dimid, len = nfit_coeffsLW) status = nf90_inq_dimid(ncid, 'minor_absorber_intervals_lower', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nminor_absorber_intervals_lower) + status = nf90_inquire_dimension(ncid, dimid, len = nminor_absorber_intervals_lowerLW) status = nf90_inq_dimid(ncid, 'minor_absorber_intervals_upper', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = nminor_absorber_intervals_upper) + status = nf90_inquire_dimension(ncid, dimid, len = nminor_absorber_intervals_upperLW) status = nf90_inq_dimid(ncid, 'temperature_Planck', dimid) - status = nf90_inquire_dimension(ncid, dimid, len = ninternalSourcetemps) - - ! Allocate space for arrays - allocate(gas_namesLW(nabsorbers)) - allocate(scaling_gas_lowerLW(nminor_absorber_intervals_lower)) - allocate(scaling_gas_upperLW(nminor_absorber_intervals_upper)) - allocate(gas_minorLW(nminorabsorbers)) - allocate(identifier_minorLW(nminorabsorbers)) - allocate(minor_gases_lowerLW(nminor_absorber_intervals_lower)) - allocate(minor_gases_upperLW(nminor_absorber_intervals_upper)) - allocate(minor_limits_gpt_lowerLW(npairs,nminor_absorber_intervals_lower)) - allocate(minor_limits_gpt_upperLW(npairs,nminor_absorber_intervals_upper)) - allocate(band2gptLW(2,nbnds)) - allocate(key_speciesLW(2,nlayers,nbnds)) - allocate(band_limsLW(2,nbnds)) - allocate(press_refLW(npress)) - allocate(temp_refLW(ntemps)) - allocate(vmr_refLW(nlayers, nextrabsorbers, ntemps)) - allocate(kminor_lowerLW(ncontributors_lower, nmixingfracs, ntemps)) - allocate(kmajorLW(ngpts, nmixingfracs, npress+1, ntemps)) - allocate(kminor_start_lowerLW(nminor_absorber_intervals_lower)) - allocate(kminor_upperLW(ncontributors_upper, nmixingfracs, ntemps)) - allocate(kminor_start_upperLW(nminor_absorber_intervals_upper)) - allocate(optimal_angle_fitLW(nfit_coeffs,nbnds)) - allocate(minor_scales_with_density_lowerLW(nminor_absorber_intervals_lower)) - allocate(minor_scales_with_density_upperLW(nminor_absorber_intervals_upper)) - allocate(scale_by_complement_lowerLW(nminor_absorber_intervals_lower)) - allocate(scale_by_complement_upperLW(nminor_absorber_intervals_upper)) - allocate(temp1(nminor_absorber_intervals_lower)) - allocate(temp2(nminor_absorber_intervals_upper)) - allocate(temp3(nminor_absorber_intervals_lower)) - allocate(temp4(nminor_absorber_intervals_upper)) - allocate(totplnkLW(ninternalSourcetemps, nbnds)) - allocate(planck_fracLW(ngpts, nmixingfracs, npress+1, ntemps)) - - ! Read in fields from file - if (mpirank==mpiroot) write (*,*) 'Reading RRTMGP longwave k-distribution data ... ' + status = nf90_inquire_dimension(ncid, dimid, len = ninternalSourcetempsLW) +#ifdef MPI + endif ! On master processor + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! ####################################################################################### + ! + ! Broadcast dimensions... + ! (ALL processors) + ! + ! ####################################################################################### + call mpi_bcast(ntempsLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(npressLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(ngptsLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nabsorbersLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nextrabsorbersLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nminorabsorbersLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nmixingfracsLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nlayersLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nbndsLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(npairsLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(ninternalSourcetempsLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nminor_absorber_intervals_lowerLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nminor_absorber_intervals_upperLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(ncontributors_lowerLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(ncontributors_upperLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nfit_coeffsLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) +#endif + + ! Allocate space for arrays + if (.not. allocated(gas_namesLW)) & + allocate(gas_namesLW(nabsorbersLW)) + if (.not. allocated(scaling_gas_lowerLW)) & + allocate(scaling_gas_lowerLW(nminor_absorber_intervals_lowerLW)) + if (.not. allocated(scaling_gas_upperLW)) & + allocate(scaling_gas_upperLW(nminor_absorber_intervals_upperLW)) + if (.not. allocated(gas_minorLW)) & + allocate(gas_minorLW(nminorabsorbersLW)) + if (.not. allocated(identifier_minorLW)) & + allocate(identifier_minorLW(nminorabsorbersLW)) + if (.not. allocated(minor_gases_lowerLW)) & + allocate(minor_gases_lowerLW(nminor_absorber_intervals_lowerLW)) + if (.not. allocated(minor_gases_upperLW)) & + allocate(minor_gases_upperLW(nminor_absorber_intervals_upperLW)) + if (.not. allocated(minor_limits_gpt_lowerLW)) & + allocate(minor_limits_gpt_lowerLW(npairsLW, nminor_absorber_intervals_lowerLW)) + if (.not. allocated(minor_limits_gpt_upperLW)) & + allocate(minor_limits_gpt_upperLW(npairsLW, nminor_absorber_intervals_upperLW)) + if (.not. allocated(band2gptLW)) & + allocate(band2gptLW(2, nbndsLW)) + if (.not. allocated(key_speciesLW)) & + allocate(key_speciesLW(2, nlayersLW, nbndsLW)) + if (.not. allocated(band_limsLW)) & + allocate(band_limsLW(2, nbndsLW)) + if (.not. allocated(press_refLW)) & + allocate(press_refLW(npressLW)) + if (.not. allocated(temp_refLW)) & + allocate(temp_refLW(ntempsLW)) + if (.not. allocated(vmr_refLW)) & + allocate(vmr_refLW(nlayersLW, nextrabsorbersLW, ntempsLW)) + if (.not. allocated(kminor_lowerLW)) & + allocate(kminor_lowerLW(ncontributors_lowerLW, nmixingfracsLW, ntempsLW)) + if (.not. allocated(kmajorLW)) & + allocate(kmajorLW(ngptsLW, nmixingfracsLW, npressLW+1, ntempsLW)) + if (.not. allocated(kminor_start_lowerLW)) & + allocate(kminor_start_lowerLW(nminor_absorber_intervals_lowerLW)) + if (.not. allocated(kminor_upperLW)) & + allocate(kminor_upperLW(ncontributors_upperLW, nmixingfracsLW, ntempsLW)) + if (.not. allocated(kminor_start_upperLW)) & + allocate(kminor_start_upperLW(nminor_absorber_intervals_upperLW)) + if (.not. allocated(optimal_angle_fitLW)) & + allocate(optimal_angle_fitLW(nfit_coeffsLW, nbndsLW)) + if (.not. allocated(minor_scales_with_density_lowerLW)) & + allocate(minor_scales_with_density_lowerLW(nminor_absorber_intervals_lowerLW)) + if (.not. allocated(minor_scales_with_density_upperLW)) & + allocate(minor_scales_with_density_upperLW(nminor_absorber_intervals_upperLW)) + if (.not. allocated(scale_by_complement_lowerLW)) & + allocate(scale_by_complement_lowerLW(nminor_absorber_intervals_lowerLW)) + if (.not. allocated(scale_by_complement_upperLW)) & + allocate(scale_by_complement_upperLW(nminor_absorber_intervals_upperLW)) + if (.not. allocated(temp1)) & + allocate(temp1(nminor_absorber_intervals_lowerLW)) + if (.not. allocated(temp2)) & + allocate(temp2(nminor_absorber_intervals_upperLW)) + if (.not. allocated(temp3)) & + allocate(temp3(nminor_absorber_intervals_lowerLW)) + if (.not. allocated(temp4)) & + allocate(temp4(nminor_absorber_intervals_upperLW)) + if (.not. allocated(totplnkLW)) & + allocate(totplnkLW(ninternalSourcetempsLW, nbndsLW)) + if (.not. allocated(planck_fracLW)) & + allocate(planck_fracLW(ngptsLW, nmixingfracsLW, npressLW+1, ntempsLW)) + + ! ####################################################################################### + ! + ! Read in data ... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### +#ifdef MPI + call mpi_barrier(mpicomm, mpierr) + if (mpirank .eq. mpiroot) then +#endif + write (*,*) 'Reading RRTMGP longwave k-distribution data ... ' status = nf90_inq_varid(ncid, 'gas_names', varID) status = nf90_get_var( ncid, varID, gas_namesLW) status = nf90_inq_varid(ncid, 'scaling_gas_lower', varID) @@ -249,25 +328,120 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, gas_co status = nf90_get_var( ncid, varID,temp4) status = nf90_close(ncid) - do ii=1,nminor_absorber_intervals_lower + do ii=1,nminor_absorber_intervals_lowerLW if (temp1(ii) .eq. 0) minor_scales_with_density_lowerLW(ii) = .false. if (temp1(ii) .eq. 1) minor_scales_with_density_lowerLW(ii) = .true. if (temp3(ii) .eq. 0) scale_by_complement_lowerLW(ii) = .false. if (temp3(ii) .eq. 1) scale_by_complement_lowerLW(ii) = .true. enddo - do ii=1,nminor_absorber_intervals_upper + do ii=1,nminor_absorber_intervals_upperLW if (temp2(ii) .eq. 0) minor_scales_with_density_upperLW(ii) = .false. if (temp2(ii) .eq. 1) minor_scales_with_density_upperLW(ii) = .true. if (temp4(ii) .eq. 0) scale_by_complement_upperLW(ii) = .false. if (temp4(ii) .eq. 1) scale_by_complement_upperLW(ii) = .true. enddo -! endif +#ifdef MPI + endif ! Master process + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + ! ####################################################################################### ! + ! Broadcast data... + ! (ALL processors) + ! + ! ####################################################################################### + + ! Real scalars + call mpi_bcast(press_ref_tropLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(temp_ref_pLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(temp_ref_tLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + + ! Integer arrays + call mpi_bcast(kminor_start_lowerLW, & + size(kminor_start_lowerLW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(kminor_start_upperLW, & + size(kminor_start_upperLW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(band2gptLW, & + size(band2gptLW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(minor_limits_gpt_lowerLW, & + size(minor_limits_gpt_lowerLW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(minor_limits_gpt_upperLW, & + size(minor_limits_gpt_upperLW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(key_speciesLW, & + size(key_speciesLW), MPI_INTEGER, mpiroot, mpicomm, mpierr) + + ! Real arrays + call mpi_bcast(press_refLW, & + size(press_refLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(temp_refLW, & + size(temp_refLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(band_limsLW, & + size(band_limsLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(totplnkLW, & + size(totplnkLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(optimal_angle_fitLW, & + size(optimal_angle_fitLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(vmr_refLW, & + size(vmr_refLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(kminor_lowerLW, & + size(kminor_lowerLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(kminor_upperLW, & + size(kminor_upperLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(rayl_lowerLW, & + size(rayl_lowerLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(rayl_upperLW, & + size(rayl_upperLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(kmajorLW, & + size(kmajorLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(planck_fracLW, & + size(planck_fracLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + + + ! Characters + do iChar=1,nabsorbersLW + call mpi_bcast(gas_namesLW(iChar), & + len(gas_namesLW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + enddo + do iChar=1,nminorabsorbersLW + call mpi_bcast(gas_minorLW(iChar), & + len(gas_minorLW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(identifier_minorLW(iChar), & + len(identifier_minorLW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + enddo + do iChar=1,nminor_absorber_intervals_lowerLW + call mpi_bcast(minor_gases_lowerLW(iChar), & + len(minor_gases_lowerLW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(scaling_gas_lowerLW(iChar), & + len(scaling_gas_lowerLW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + enddo + do iChar=1,nminor_absorber_intervals_upperLW + call mpi_bcast(minor_gases_upperLW(iChar), & + len(minor_gases_upperLW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + call mpi_bcast(scaling_gas_upperLW(iChar), & + len(scaling_gas_upperLW(iChar)), MPI_CHARACTER, mpiroot, mpicomm, mpierr) + enddo + + ! Logicals + call mpi_bcast(minor_scales_with_density_lowerLW, & + size(minor_scales_with_density_lowerLW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call mpi_bcast(minor_scales_with_density_upperLW, & + size(minor_scales_with_density_upperLW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call mpi_bcast(scale_by_complement_lowerLW, & + size(scale_by_complement_lowerLW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + call mpi_bcast(scale_by_complement_upperLW, & + size(scale_by_complement_upperLW), MPI_LOGICAL, mpiroot, mpicomm, mpierr) + + call mpi_barrier(mpicomm, mpierr) +#endif + + ! ####################################################################################### + ! ! Initialize RRTMGP DDT's... ! + ! ####################################################################################### !$omp critical (load_lw_gas_optics) - ! Longwave k-distribution data. gas_concentrations%gas_name(:) = active_gases_array(:) call check_error_msg('rrtmgp_lw_gas_optics_init',lw_gas_props%load(gas_concentrations, & gas_namesLW, key_speciesLW, band2gptLW, band_limsLW, press_refLW, press_ref_tropLW,& diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index c6eb3d145..92e35e06f 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -34,22 +34,6 @@ type = ty_gas_concs intent = inout optional = F -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[nLev] - standard_name = vertical_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in - optional = F [mpirank] standard_name = mpi_rank long_name = current MPI rank From f3393f40b2858424f6db6b650acab9339e9e9363 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 18 Feb 2021 18:23:45 +0000 Subject: [PATCH 09/12] MPI broadcast working in SW/LW cloud-optics initialization. --- physics/rrtmgp_lw_cloud_optics.F90 | 249 +++++++++++++++++++-------- physics/rrtmgp_lw_cloud_optics.meta | 24 --- physics/rrtmgp_sw_cloud_optics.F90 | 256 ++++++++++++++++++++-------- physics/rrtmgp_sw_cloud_optics.meta | 32 ---- 4 files changed, 366 insertions(+), 195 deletions(-) diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index d8aa7e9f0..42c14ee94 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -7,12 +7,16 @@ module rrtmgp_lw_cloud_optics use rrtmgp_lw_gas_optics, only: lw_gas_props use rrtmgp_aux, only: check_error_msg use netcdf +#ifdef MPI + use mpi +#endif implicit none - public rrtmgp_lw_cloud_optics_init, rrtmgp_lw_cloud_optics_run, rrtmgp_lw_cloud_optics_finalize - type(ty_cloud_optics) :: lw_cloud_props + integer :: & + nrghice_fromfileLW, nBandLW, nSize_liqLW, nSize_iceLW, nSizeRegLW, & + nCoeff_extLW, nCoeff_ssa_gLW, nBoundLW, npairsLW real(kind_phys) :: & radliq_facLW, & ! Factor for calculating LUT interpolation indices for liquid radice_facLW ! Factor for calculating LUT interpolation indices for ice @@ -66,7 +70,7 @@ module rrtmgp_lw_cloud_optics !! \section arg_table_rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! - subroutine rrtmgp_lw_cloud_optics_init(nCol, nLev, nbndsGPlw, doG_cldoptics, & + subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, & doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, & rrtmgp_lw_file_clouds, mpicomm, mpirank, mpiroot, errmsg, errflg) @@ -78,9 +82,6 @@ subroutine rrtmgp_lw_cloud_optics_init(nCol, nLev, nbndsGPlw, doG_cldoptics, integer, intent(inout) :: & nrghice ! Number of ice-roughness categories integer, intent(in) :: & - nbndsGPlw, & ! Number of longwave bands - nCol, & ! Number of horizontal gridpoints - nLev, & ! Number of vertical levels mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank @@ -94,13 +95,8 @@ subroutine rrtmgp_lw_cloud_optics_init(nCol, nLev, nbndsGPlw, doG_cldoptics, integer, intent(out) :: & errflg ! Error code - ! Dimensions - integer :: & - nrghice_fromfile, nBand, nSize_liq, nSize_ice, nSizeReg,& - nCoeff_ext, nCoeff_ssa_g, nBound, npairs - ! Local variables - integer :: dimID,varID,status,ncid + integer :: dimID,varID,status,ncid,mpierr character(len=264) :: lw_cloud_props_file integer,parameter :: max_strlen=256, nrghice_default=2 @@ -110,68 +106,113 @@ subroutine rrtmgp_lw_cloud_optics_init(nCol, nLev, nbndsGPlw, doG_cldoptics, ! If not using RRTMGP cloud optics, return. if (doG_cldoptics) return - - ! - ! Otherwise, using RRTMGP cloud-optics, continue with initialization... - ! ! Filenames are set in the physics_nml lw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_lw_file_clouds) - ! On master processor only... -! if (mpirank .eq. mpiroot) then + ! ####################################################################################### + ! + ! Read dimensions for longwave cloud-optics fields... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + write (*,*) 'Reading RRTMGP longwave cloud-optics metadata ... ' + ! Open file status = nf90_open(trim(lw_cloud_props_file), NF90_NOWRITE, ncid) - + ! Read dimensions status = nf90_inq_dimid(ncid, 'nband', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nBand) + status = nf90_inquire_dimension(ncid, dimid, len=nBandLW) status = nf90_inq_dimid(ncid, 'nrghice', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nrghice_fromfile) + status = nf90_inquire_dimension(ncid, dimid, len=nrghice_fromfileLW) status = nf90_inq_dimid(ncid, 'nsize_liq', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nSize_liq) + status = nf90_inquire_dimension(ncid, dimid, len=nSize_liqLW) status = nf90_inq_dimid(ncid, 'nsize_ice', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nSize_ice) + status = nf90_inquire_dimension(ncid, dimid, len=nSize_iceLW) status = nf90_inq_dimid(ncid, 'nsizereg', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nSizeReg) + status = nf90_inquire_dimension(ncid, dimid, len=nSizeRegLW) status = nf90_inq_dimid(ncid, 'ncoeff_ext', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nCoeff_ext) + status = nf90_inquire_dimension(ncid, dimid, len=nCoeff_extLW) status = nf90_inq_dimid(ncid, 'ncoeff_ssa_g', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nCoeff_ssa_g) + status = nf90_inquire_dimension(ncid, dimid, len=nCoeff_ssa_gLW) status = nf90_inq_dimid(ncid, 'nbound', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nBound) + status = nf90_inquire_dimension(ncid, dimid, len=nBoundLW) status = nf90_inq_dimid(ncid, 'pair', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=npairs) + status = nf90_inquire_dimension(ncid, dimid, len=npairsLW) - ! Has the number of ice-roughnesses to use been provided from the namelist? - ! If not, use nrghice from cloud-optics data file. - if (nrghice .eq. 0) nrghice = nrghice_fromfile +#ifdef MPI + endif ! On master processor - ! Allocate space for arrays - if (doGP_cldoptics_LUT) then - allocate(lut_extliqLW(nSize_liq, nBand)) - allocate(lut_ssaliqLW(nSize_liq, nBand)) - allocate(lut_asyliqLW(nSize_liq, nBand)) - allocate(lut_exticeLW(nSize_ice, nBand, nrghice)) - allocate(lut_ssaiceLW(nSize_ice, nBand, nrghice)) - allocate(lut_asyiceLW(nSize_ice, nBand, nrghice)) - endif - if (doGP_cldoptics_PADE) then - allocate(pade_extliqLW(nBand, nSizeReg, nCoeff_ext )) - allocate(pade_ssaliqLW(nBand, nSizeReg, nCoeff_ssa_g)) - allocate(pade_asyliqLW(nBand, nSizeReg, nCoeff_ssa_g)) - allocate(pade_exticeLW(nBand, nSizeReg, nCoeff_ext, nrghice)) - allocate(pade_ssaiceLW(nBand, nSizeReg, nCoeff_ssa_g, nrghice)) - allocate(pade_asyiceLW(nBand, nSizeReg, nCoeff_ssa_g, nrghice)) - allocate(pade_sizereg_extliqLW(nBound)) - allocate(pade_sizereg_ssaliqLW(nBound)) - allocate(pade_sizereg_asyliqLW(nBound)) - allocate(pade_sizereg_exticeLW(nBound)) - allocate(pade_sizereg_ssaiceLW(nBound)) - allocate(pade_sizereg_asyiceLW(nBound)) - endif - allocate(band_limsCLDLW(2,nBand)) + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! ####################################################################################### + ! + ! Broadcast dimensions... + ! (ALL processors) + ! + ! ####################################################################################### + call mpi_bcast(nBandLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nSize_liqLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nSize_iceLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nSizeregLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nCoeff_extLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nCoeff_ssa_gLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nBoundLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nPairsLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) +#endif + + ! Has the number of ice-roughnesses to use been provided from the namelist? + ! If so, override nrghice from cloud-optics file + if (nrghice .ne. 0) nrghice_fromfileLW = nrghice +#ifdef MPI + call mpi_bcast(nrghice_fromfileLW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) +#endif + + ! ####################################################################################### + ! + ! Allocate space for arrays... + ! (ALL processors) + ! + ! ####################################################################################### + if (doGP_cldoptics_LUT) then + allocate(lut_extliqLW(nSize_liqLW, nBandLW)) + allocate(lut_ssaliqLW(nSize_liqLW, nBandLW)) + allocate(lut_asyliqLW(nSize_liqLW, nBandLW)) + allocate(lut_exticeLW(nSize_iceLW, nBandLW, nrghice_fromfileLW)) + allocate(lut_ssaiceLW(nSize_iceLW, nBandLW, nrghice_fromfileLW)) + allocate(lut_asyiceLW(nSize_iceLW, nBandLW, nrghice_fromfileLW)) + endif + if (doGP_cldoptics_PADE) then + allocate(pade_extliqLW(nBandLW, nSizeRegLW, nCoeff_extLW )) + allocate(pade_ssaliqLW(nBandLW, nSizeRegLW, nCoeff_ssa_gLW)) + allocate(pade_asyliqLW(nBandLW, nSizeRegLW, nCoeff_ssa_gLW)) + allocate(pade_exticeLW(nBandLW, nSizeRegLW, nCoeff_extLW, nrghice_fromfileLW)) + allocate(pade_ssaiceLW(nBandLW, nSizeRegLW, nCoeff_ssa_gLW, nrghice_fromfileLW)) + allocate(pade_asyiceLW(nBandLW, nSizeRegLW, nCoeff_ssa_gLW, nrghice_fromfileLW)) + allocate(pade_sizereg_extliqLW(nBoundLW)) + allocate(pade_sizereg_ssaliqLW(nBoundLW)) + allocate(pade_sizereg_asyliqLW(nBoundLW)) + allocate(pade_sizereg_exticeLW(nBoundLW)) + allocate(pade_sizereg_ssaiceLW(nBoundLW)) + allocate(pade_sizereg_asyiceLW(nBoundLW)) + endif + allocate(band_limsCLDLW(2,nBandLW)) + ! ####################################################################################### + ! + ! Read in data ... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### +#ifdef MPI + call mpi_barrier(mpicomm, mpierr) + if (mpirank .eq. mpiroot) then +#endif ! Read in fields from file if (doGP_cldoptics_LUT) then write (*,*) 'Reading RRTMGP longwave cloud data (LUT) ... ' @@ -246,24 +287,96 @@ subroutine rrtmgp_lw_cloud_optics_init(nCol, nLev, nbndsGPlw, doG_cldoptics, ! Close file status = nf90_close(ncid) -! endif - - ! Load tables data for RRTMGP cloud-optics +#ifdef MPI + endif ! Master process + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! ####################################################################################### + ! + ! Broadcast data... + ! (ALL processors) + ! + ! ####################################################################################### + + ! Real scalars + call mpi_bcast(radliq_facLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radice_facLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radliq_lwrLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radliq_uprLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radice_lwrLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radice_uprLW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + + ! Real arrays + call mpi_bcast(band_limsCLDLW, size(band_limsCLDLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + if (doGP_cldoptics_LUT) then + call mpi_bcast(lut_extliqLW, size(lut_extliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_ssaliqLW, size(lut_ssaliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_asyliqLW, size(lut_asyliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_exticeLW, size(lut_exticeLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_ssaiceLW, size(lut_ssaiceLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_asyiceLW, size(lut_asyiceLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (doGP_cldoptics_PADE) then + call mpi_bcast(pade_extliqLW, size(pade_extliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_ssaliqLW, size(pade_ssaliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_asyliqLW, size(pade_asyliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_exticeLW, size(pade_exticeLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_ssaiceLW, size(pade_ssaiceLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_asyiceLW, size(pade_asyiceLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_extliqLW, size(pade_sizereg_extliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_ssaliqLW, size(pade_sizereg_ssaliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_asyliqLW, size(pade_sizereg_asyliqLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_exticeLW, size(pade_sizereg_exticeLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_ssaiceLW, size(pade_sizereg_ssaiceLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_asyiceLW, size(pade_sizereg_asyiceLW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif +#endif + + ! ####################################################################################### + ! + ! Initialize RRTMGP DDT's... + ! + ! ####################################################################################### if (doGP_cldoptics_LUT) then !$omp critical (load_lw_cloud_props_LUTs) - call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_limsCLDLW, & - radliq_lwrLW, radliq_uprLW, radliq_facLW, radice_lwrLW, radice_uprLW, radice_facLW, & - lut_extliqLW, lut_ssaliqLW, lut_asyliqLW, lut_exticeLW, lut_ssaiceLW, lut_asyiceLW)) + call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_limsCLDLW, & + radliq_lwrLW, radliq_uprLW, radliq_facLW, radice_lwrLW, radice_uprLW, & + radice_facLW, lut_extliqLW, lut_ssaliqLW, lut_asyliqLW, lut_exticeLW, & + lut_ssaiceLW, lut_asyiceLW)) !$omp end critical (load_lw_cloud_props_LUTs) endif + if (doGP_cldoptics_PADE) then !$omp critical (load_lw_cloud_props_PADE_approx) - call check_error_msg('lw_cloud_optics_init', lw_cloud_props%load(band_limsCLDLW, & - pade_extliqLW, pade_ssaliqLW, pade_asyliqLW, pade_exticeLW, pade_ssaiceLW, pade_asyiceLW,& - pade_sizereg_extliqLW, pade_sizereg_ssaliqLW, pade_sizereg_asyliqLW, & - pade_sizereg_exticeLW, pade_sizereg_ssaiceLW, pade_sizereg_asyiceLW)) + call check_error_msg('lw_cloud_optics_init', lw_cloud_props%load(band_limsCLDLW, & + pade_extliqLW, pade_ssaliqLW, pade_asyliqLW, pade_exticeLW, pade_ssaiceLW, & + pade_asyiceLW, pade_sizereg_extliqLW, pade_sizereg_ssaliqLW, & + pade_sizereg_asyliqLW, pade_sizereg_exticeLW, pade_sizereg_ssaiceLW, & + pade_sizereg_asyiceLW)) !$omp endcritical (load_lw_cloud_props_PADE_approx) endif + !$omp critical (load_lw_cloud_props_nrghice) call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(nrghice)) !$omp end critical (load_lw_cloud_props_nrghice) @@ -277,9 +390,9 @@ end subroutine rrtmgp_lw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! subroutine rrtmgp_lw_cloud_optics_run(doLWrad, doG_cldoptics, icliq_lw, icice_lw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, nCol, nLev, nbndsGPlw, p_lay, & - cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & - cld_rerain, precip_frac, lon, lat, cldtaulw, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_lwscat, nCol, nLev, nbndsGPlw, & + p_lay, cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, & + cld_rwp, cld_rerain, precip_frac, lon, lat, cldtaulw, & lw_optical_props_cloudsByBand, lw_optical_props_precipByBand, errmsg, errflg) ! Inputs diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index 80cf60bf5..14852f3a0 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -7,30 +7,6 @@ [ccpp-arg-table] name = rrtmgp_lw_cloud_optics_init type = scheme -[nbndsGPlw] - standard_name = number_of_lw_bands_rrtmgp - long_name = number of lw bands used in RRTMGP - units = count - dimensions = () - type = integer - intent = in - optional = F -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[nLev] - standard_name = vertical_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in - optional = F [doG_cldoptics] standard_name = flag_to_calc_lw_cld_optics_using_RRTMG long_name = logical flag to control cloud optics scheme. diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 611cb44c2..1b0500650 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -7,12 +7,16 @@ module rrtmgp_sw_cloud_optics use rrtmgp_sw_gas_optics, only: sw_gas_props use rrtmgp_aux, only: check_error_msg use netcdf +#ifdef MPI + use mpi +#endif implicit none - - public rrtmgp_sw_cloud_optics_init, rrtmgp_sw_cloud_optics_run, rrtmgp_sw_cloud_optics_finalize type(ty_cloud_optics) :: sw_cloud_props + integer :: & + nrghice_fromfileSW, nBandSW, nSize_liqSW, nSize_iceSW, nSizeregSW, & + nCoeff_extSW, nCoeff_ssa_gSW, nBoundSW, nPairsSW real(kind_phys) :: & radliq_facSW, & ! Factor for calculating LUT interpolation indices for liquid radice_facSW ! Factor for calculating LUT interpolation indices for ice @@ -66,7 +70,7 @@ module rrtmgp_sw_cloud_optics !! \section arg_table_rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_lw_cloud_optics.html !! - subroutine rrtmgp_sw_cloud_optics_init(nCol, nLev, nbndsGPsw, doG_cldoptics, doGP_cldoptics_PADE, & + subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, & doGP_cldoptics_LUT, nrghice, rrtmgp_root_dir, rrtmgp_sw_file_clouds, mpicomm, & mpirank, mpiroot, errmsg, errflg) @@ -78,12 +82,9 @@ subroutine rrtmgp_sw_cloud_optics_init(nCol, nLev, nbndsGPsw, doG_cldoptics, doG integer, intent(inout) :: & nrghice ! Number of ice-roughness categories integer, intent(in) :: & - nbndsGPsw, & ! Number of bands used in shortwave. mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank - mpiroot, & ! Master MPI rank - nCol, & ! Number of horizontal gridpoints - nLev ! Number of vertical levels + mpiroot ! Master MPI rank character(len=128),intent(in) :: & rrtmgp_root_dir, & ! RTE-RRTMGP root directory rrtmgp_sw_file_clouds ! RRTMGP file containing coefficients used to compute clouds optical properties @@ -94,15 +95,9 @@ subroutine rrtmgp_sw_cloud_optics_init(nCol, nLev, nbndsGPsw, doG_cldoptics, doG integer, intent(out) :: & errflg ! CCPP error code - ! Dimensions - integer :: & - nrghice_fromfile, nBand, nSize_liq, nSize_ice, nSizereg,& - nCoeff_ext, nCoeff_ssa_g, nBound, nPairs - ! Local variables - integer :: status,ncid,dimid,varID + integer :: status,ncid,dimid,varID,mpierr character(len=264) :: sw_cloud_props_file - integer,parameter :: nrghice_default=2 ! Initialize errmsg = '' @@ -113,61 +108,108 @@ subroutine rrtmgp_sw_cloud_optics_init(nCol, nLev, nbndsGPsw, doG_cldoptics, doG ! Filenames are set in the physics_nml sw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_sw_file_clouds) - ! On master processor only... -! if (mpirank .eq. mpiroot) then + ! ####################################################################################### + ! + ! Read dimensions for shortwave cloud-optics fields... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + write (*,*) 'Reading RRTMGP shortwave cloud-optics metadata ... ' + ! Open file status = nf90_open(trim(sw_cloud_props_file), NF90_NOWRITE, ncid) ! Read dimensions status = nf90_inq_dimid(ncid, 'nband', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nBand) + status = nf90_inquire_dimension(ncid, dimid, len=nBandSW) status = nf90_inq_dimid(ncid, 'nrghice', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nrghice_fromfile) + status = nf90_inquire_dimension(ncid, dimid, len=nrghice_fromfileSW) status = nf90_inq_dimid(ncid, 'nsize_liq', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nSize_liq) + status = nf90_inquire_dimension(ncid, dimid, len=nSize_liqSW) status = nf90_inq_dimid(ncid, 'nsize_ice', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nSize_ice) + status = nf90_inquire_dimension(ncid, dimid, len=nSize_iceSW) status = nf90_inq_dimid(ncid, 'nsizereg', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nSizereg) + status = nf90_inquire_dimension(ncid, dimid, len=nSizeregSW) status = nf90_inq_dimid(ncid, 'ncoeff_ext', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nCoeff_ext) + status = nf90_inquire_dimension(ncid, dimid, len=nCoeff_extSW) status = nf90_inq_dimid(ncid, 'ncoeff_ssa_g', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nCoeff_ssa_g) + status = nf90_inquire_dimension(ncid, dimid, len=nCoeff_ssa_gSW) status = nf90_inq_dimid(ncid, 'nbound', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nBound) + status = nf90_inquire_dimension(ncid, dimid, len=nBoundSW) status = nf90_inq_dimid(ncid, 'pair', dimid) - status = nf90_inquire_dimension(ncid, dimid, len=nPairs) - - ! Has the number of ice-roughnesses provided from the namelist? - ! If not, use nrghice from cloud-optics file - if (nrghice .eq. 0) nrghice = nrghice_fromfile + status = nf90_inquire_dimension(ncid, dimid, len=nPairsSW) +#ifdef MPI + endif ! On master processor - ! Allocate space for arrays - if (doGP_cldoptics_LUT) then - allocate(lut_extliqSW(nSize_liq, nBand)) - allocate(lut_ssaliqSW(nSize_liq, nBand)) - allocate(lut_asyliqSW(nSize_liq, nBand)) - allocate(lut_exticeSW(nSize_ice, nBand, nrghice)) - allocate(lut_ssaiceSW(nSize_ice, nBand, nrghice)) - allocate(lut_asyiceSW(nSize_ice, nBand, nrghice)) - endif - if (doGP_cldoptics_PADE) then - allocate(pade_extliqSW(nBand, nSizeReg, nCoeff_ext )) - allocate(pade_ssaliqSW(nBand, nSizeReg, nCoeff_ssa_g)) - allocate(pade_asyliqSW(nBand, nSizeReg, nCoeff_ssa_g)) - allocate(pade_exticeSW(nBand, nSizeReg, nCoeff_ext, nrghice)) - allocate(pade_ssaiceSW(nBand, nSizeReg, nCoeff_ssa_g, nrghice)) - allocate(pade_asyiceSW(nBand, nSizeReg, nCoeff_ssa_g, nrghice)) - allocate(pade_sizereg_extliqSW(nBound)) - allocate(pade_sizereg_ssaliqSW(nBound)) - allocate(pade_sizereg_asyliqSW(nBound)) - allocate(pade_sizereg_exticeSW(nBound)) - allocate(pade_sizereg_ssaiceSW(nBound)) - allocate(pade_sizereg_asyiceSW(nBound)) - endif - allocate(band_limsCLDSW(2,nBand)) + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! ####################################################################################### + ! + ! Broadcast dimensions... + ! (ALL processors) + ! + ! ####################################################################################### + call mpi_bcast(nBandSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nSize_liqSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nSize_iceSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nSizeregSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nCoeff_extSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nCoeff_ssa_gSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nBoundSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nPairsSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) +#endif + + ! Has the number of ice-roughnesses provided from the namelist? + ! If so, override nrghice from cloud-optics file + if (nrghice .ne. 0) nrghice_fromfileSW = nrghice +#ifdef MPI + call mpi_bcast(nrghice_fromfileSW, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) +#endif + + ! ####################################################################################### + ! + ! Allocate space for arrays... + ! (ALL processors) + ! + ! ####################################################################################### + if (doGP_cldoptics_LUT) then + allocate(lut_extliqSW(nSize_liqSW, nBandSW)) + allocate(lut_ssaliqSW(nSize_liqSW, nBandSW)) + allocate(lut_asyliqSW(nSize_liqSW, nBandSW)) + allocate(lut_exticeSW(nSize_iceSW, nBandSW, nrghice_fromfileSW)) + allocate(lut_ssaiceSW(nSize_iceSW, nBandSW, nrghice_fromfileSW)) + allocate(lut_asyiceSW(nSize_iceSW, nBandSW, nrghice_fromfileSW)) + endif + if (doGP_cldoptics_PADE) then + allocate(pade_extliqSW(nBandSW, nSizeRegSW, nCoeff_extSW )) + allocate(pade_ssaliqSW(nBandSW, nSizeRegSW, nCoeff_ssa_gSW)) + allocate(pade_asyliqSW(nBandSW, nSizeRegSW, nCoeff_ssa_gSW)) + allocate(pade_exticeSW(nBandSW, nSizeRegSW, nCoeff_extSW, nrghice_fromfileSW)) + allocate(pade_ssaiceSW(nBandSW, nSizeRegSW, nCoeff_ssa_gSW, nrghice_fromfileSW)) + allocate(pade_asyiceSW(nBandSW, nSizeRegSW, nCoeff_ssa_gSW, nrghice_fromfileSW)) + allocate(pade_sizereg_extliqSW(nBoundSW)) + allocate(pade_sizereg_ssaliqSW(nBoundSW)) + allocate(pade_sizereg_asyliqSW(nBoundSW)) + allocate(pade_sizereg_exticeSW(nBoundSW)) + allocate(pade_sizereg_ssaiceSW(nBoundSW)) + allocate(pade_sizereg_asyiceSW(nBoundSW)) + endif + allocate(band_limsCLDSW(2,nBandSW)) - ! Read in fields from file + ! ####################################################################################### + ! + ! Read in data ... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### +#ifdef MPI + call mpi_barrier(mpicomm, mpierr) + if (mpirank .eq. mpiroot) then +#endif if (doGP_cldoptics_LUT) then write (*,*) 'Reading RRTMGP shortwave cloud data (LUT) ... ' status = nf90_inq_varid(ncid,'radliq_lwr',varID) @@ -241,26 +283,99 @@ subroutine rrtmgp_sw_cloud_optics_init(nCol, nLev, nbndsGPsw, doG_cldoptics, doG ! Close file status = nf90_close(ncid) -! endif - ! Load tables data for RRTMGP cloud-optics +#ifdef MPI + endif ! Master process + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! ####################################################################################### + ! + ! Broadcast data... + ! (ALL processors) + ! + ! ####################################################################################### + + ! Real scalars + call mpi_bcast(radliq_facSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radice_facSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radliq_lwrSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radliq_uprSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radice_lwrSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(radice_uprSW, 1, MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + + ! Real arrays + call mpi_bcast(band_limsCLDSW, size(band_limsCLDSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + if (doGP_cldoptics_LUT) then + call mpi_bcast(lut_extliqSW, size(lut_extliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_ssaliqSW, size(lut_ssaliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_asyliqSW, size(lut_asyliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_exticeSW, size(lut_exticeSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_ssaiceSW, size(lut_ssaiceSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(lut_asyiceSW, size(lut_asyiceSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (doGP_cldoptics_PADE) then + call mpi_bcast(pade_extliqSW, size(pade_extliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_ssaliqSW, size(pade_ssaliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_asyliqSW, size(pade_asyliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_exticeSW, size(pade_exticeSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_ssaiceSW, size(pade_ssaiceSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_asyiceSW, size(pade_asyiceSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_extliqSW, size(pade_sizereg_extliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_ssaliqSW, size(pade_sizereg_ssaliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_asyliqSW, size(pade_sizereg_asyliqSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_exticeSW, size(pade_sizereg_exticeSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_ssaiceSW, size(pade_sizereg_ssaiceSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(pade_sizereg_asyiceSW, size(pade_sizereg_asyiceSW), & + MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif +#endif + + ! ####################################################################################### + ! + ! Initialize RRTMGP DDT's... + ! + ! ####################################################################################### if (doGP_cldoptics_LUT) then !$omp critical (load_sw_cloud_props_LUTs) - call check_error_msg('sw_cloud_optics_init',sw_cloud_props%load(band_limsCLDSW, & - radliq_lwrSW, radliq_uprSW, radliq_facSW, radice_lwrSW, radice_uprSW, radice_facSW, & - lut_extliqSW, lut_ssaliqSW, lut_asyliqSW, lut_exticeSW, lut_ssaiceSW, lut_asyiceSW)) + call check_error_msg('sw_cloud_optics_init',sw_cloud_props%load(band_limsCLDSW, & + radliq_lwrSW, radliq_uprSW, radliq_facSW, radice_lwrSW, radice_uprSW, & + radice_facSW, lut_extliqSW, lut_ssaliqSW, lut_asyliqSW, lut_exticeSW, & + lut_ssaiceSW, lut_asyiceSW)) !$omp end critical (load_sw_cloud_props_LUTs) endif + if (doGP_cldoptics_PADE) then !$omp critical (load_sw_cloud_props_PADE_approx) - call check_error_msg('sw_cloud_optics_init', sw_cloud_props%load(band_limsCLDSW, & - pade_extliqSW, pade_ssaliqSW, pade_asyliqSW, pade_exticeSW, pade_ssaiceSW, pade_asyiceSW,& - pade_sizereg_extliqSW, pade_sizereg_ssaliqSW, pade_sizereg_asyliqSW, & - pade_sizereg_exticeSW, pade_sizereg_ssaiceSW, pade_sizereg_asyiceSW)) + call check_error_msg('sw_cloud_optics_init', sw_cloud_props%load(band_limsCLDSW, & + pade_extliqSW, pade_ssaliqSW, pade_asyliqSW, pade_exticeSW, pade_ssaiceSW, & + pade_asyiceSW, pade_sizereg_extliqSW, pade_sizereg_ssaliqSW, & + pade_sizereg_asyliqSW, pade_sizereg_exticeSW, pade_sizereg_ssaiceSW, & + pade_sizereg_asyiceSW)) !$omp end critical (load_sw_cloud_props_PADE_approx) endif + !$omp critical (load_sw_cloud_props_nrghice) - call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(nrghice)) + call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(nrghice_fromfileSW)) !$omp end critical (load_sw_cloud_props_nrghice) ! Initialize coefficients for rain and snow(+groupel) cloud optics @@ -289,9 +404,9 @@ end subroutine rrtmgp_sw_cloud_optics_init !! \htmlinclude rrtmgp_sw_cloud_optics.html !! subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw, & - doGP_cldoptics_PADE, doGP_cldoptics_LUT, nCol, nLev, nDay, nbndsGPsw, idxday, nrghice, cld_frac,& - cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & - precip_frac, sw_optical_props_cloudsByBand, & + doGP_cldoptics_PADE, doGP_cldoptics_LUT, nCol, nLev, nDay, nbndsGPsw, idxday, & + cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, & + cld_rerain, precip_frac, sw_optical_props_cloudsByBand, & sw_optical_props_precipByBand, cldtausw, errmsg, errflg) ! Inputs @@ -305,7 +420,6 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw nCol, & ! Number of horizontal gridpoints nLev, & ! Number of vertical levels nday, & ! Number of daylit points. - nrghice, & ! Number of ice-roughness categories icliq_sw, & ! Choice of treatment of liquid cloud optical properties (RRTMG legacy) icice_sw ! Choice of treatment of ice cloud optical properties (RRTMG legacy) integer,intent(in),dimension(ncol) :: & @@ -398,9 +512,9 @@ subroutine rrtmgp_sw_cloud_optics_run(doSWrad, doG_cldoptics, icliq_sw, icice_sw ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec) za1 = asyw * asyw za2 = ssaw * za1 - sw_optical_props_precipByBand%tau(idxday(iDay),iLay,iBand) = (1._kind_phys - za2) * tau_prec - sw_optical_props_precipByBand%ssa(idxday(iDay),iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) - sw_optical_props_precipByBand%g(idxday(iDay),iLay,iBand) = asyw/(1+asyw) + sw_optical_props_precipByBand%tau(iDay,iLay,iBand) = (1._kind_phys - za2) * tau_prec + sw_optical_props_precipByBand%ssa(iDay,iLay,iBand) = (ssaw - za2) / (1._kind_phys - za2) + sw_optical_props_precipByBand%g(iDay,iLay,iBand) = asyw/(1+asyw) enddo endif enddo diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index 3999f844b..e50d44bc8 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -7,30 +7,6 @@ [ccpp-arg-table] name = rrtmgp_sw_cloud_optics_init type = scheme -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[nLev] - standard_name = vertical_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in - optional = F -[nbndsGPsw] - standard_name = number_of_sw_bands_rrtmgp - long_name = number of sw bands used in RRTMGP - units = count - dimensions = () - type = integer - intent = in - optional = F [doG_cldoptics] standard_name = flag_to_calc_lw_cld_optics_using_RRTMG long_name = logical flag to control cloud optics scheme. @@ -190,14 +166,6 @@ type = logical intent = in optional = F -[nrghice] - standard_name = number_of_rrtmgp_ice_roughness - long_name = number of ice-roughness categories in RRTMGP calculation - units = count - dimensions = () - type = integer - intent = in - optional = F [cld_frac] standard_name = total_cloud_fraction long_name = layer total cloud fraction From cea4252f129058e8ea15f2d789d71e8de1def1a4 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 23 Feb 2021 18:29:42 +0000 Subject: [PATCH 10/12] Changes from code review. --- physics/GFS_rrtmgp_sw_post.F90 | 2 +- physics/GFS_rrtmgp_sw_pre.F90 | 2 +- physics/rrtmgp_lw_cloud_optics.F90 | 7 ------- physics/rrtmgp_lw_gas_optics.F90 | 3 --- physics/rrtmgp_lw_rte.F90 | 2 +- physics/rrtmgp_sw_cloud_optics.F90 | 9 --------- physics/rrtmgp_sw_gas_optics.F90 | 3 --- 7 files changed, 3 insertions(+), 25 deletions(-) diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index 14dfb798a..1f195b397 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -27,7 +27,7 @@ end subroutine GFS_rrtmgp_sw_post_init !! subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky_hr, & save_diag, fhswr, coszen, coszdg, t_lay, p_lev, sfc_alb_nir_dir, sfc_alb_nir_dif, & - sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, fluxswUP_allsky, & + sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, fluxswUP_allsky, & fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, raddt, aerodp, cldsa, mbota, & mtopa, cld_frac, cldtausw, fluxr, & nirbmdi, nirdfdi, visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, & diff --git a/physics/GFS_rrtmgp_sw_pre.F90 b/physics/GFS_rrtmgp_sw_pre.F90 index 13b2e3a00..538d30417 100644 --- a/physics/GFS_rrtmgp_sw_pre.F90 +++ b/physics/GFS_rrtmgp_sw_pre.F90 @@ -30,7 +30,7 @@ end subroutine GFS_rrtmgp_sw_pre_init subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_list, & lndp_prt_list, doSWrad, solhr, lon, coslat, sinlat, snowd, sncovr, snoalb, zorl, & tsfg, tsfa, hprime, alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, lsmask, & - sfc_wts, p_lay, tv_lay, relhum, p_lev, nday, idxday, coszen, coszdg, & + sfc_wts, p_lay, tv_lay, relhum, p_lev, nday, idxday, coszen, coszdg, & sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, sfc_alb_dif, & errmsg, errflg) diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 42c14ee94..a59fe42a9 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -210,7 +210,6 @@ subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, & ! ! ####################################################################################### #ifdef MPI - call mpi_barrier(mpicomm, mpierr) if (mpirank .eq. mpiroot) then #endif ! Read in fields from file @@ -359,27 +358,21 @@ subroutine rrtmgp_lw_cloud_optics_init(doG_cldoptics, & ! ! ####################################################################################### if (doGP_cldoptics_LUT) then -!$omp critical (load_lw_cloud_props_LUTs) call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_limsCLDLW, & radliq_lwrLW, radliq_uprLW, radliq_facLW, radice_lwrLW, radice_uprLW, & radice_facLW, lut_extliqLW, lut_ssaliqLW, lut_asyliqLW, lut_exticeLW, & lut_ssaiceLW, lut_asyiceLW)) -!$omp end critical (load_lw_cloud_props_LUTs) endif if (doGP_cldoptics_PADE) then -!$omp critical (load_lw_cloud_props_PADE_approx) call check_error_msg('lw_cloud_optics_init', lw_cloud_props%load(band_limsCLDLW, & pade_extliqLW, pade_ssaliqLW, pade_asyliqLW, pade_exticeLW, pade_ssaiceLW, & pade_asyiceLW, pade_sizereg_extliqLW, pade_sizereg_ssaliqLW, & pade_sizereg_asyliqLW, pade_sizereg_exticeLW, pade_sizereg_ssaiceLW, & pade_sizereg_asyiceLW)) -!$omp endcritical (load_lw_cloud_props_PADE_approx) endif -!$omp critical (load_lw_cloud_props_nrghice) call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(nrghice)) -!$omp end critical (load_lw_cloud_props_nrghice) end subroutine rrtmgp_lw_cloud_optics_init diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index 536adaaef..7f746b8f3 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -260,7 +260,6 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, ! ! ####################################################################################### #ifdef MPI - call mpi_barrier(mpicomm, mpierr) if (mpirank .eq. mpiroot) then #endif write (*,*) 'Reading RRTMGP longwave k-distribution data ... ' @@ -441,7 +440,6 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, ! Initialize RRTMGP DDT's... ! ! ####################################################################################### -!$omp critical (load_lw_gas_optics) gas_concentrations%gas_name(:) = active_gases_array(:) call check_error_msg('rrtmgp_lw_gas_optics_init',lw_gas_props%load(gas_concentrations, & gas_namesLW, key_speciesLW, band2gptLW, band_limsLW, press_refLW, press_ref_tropLW,& @@ -452,7 +450,6 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, scaling_gas_lowerLW, scaling_gas_upperLW, scale_by_complement_lowerLW, & scale_by_complement_upperLW, kminor_start_lowerLW, kminor_start_upperLW, totplnkLW,& planck_fracLW, rayl_lowerLW, rayl_upperLW, optimal_angle_fitLW)) -!$omp end critical (load_lw_gas_optics) ! The minimum pressure allowed in GP RTE calculations. Used to bound uppermost layer ! temperature (GFS_rrtmgp_pre.F90) diff --git a/physics/rrtmgp_lw_rte.F90 b/physics/rrtmgp_lw_rte.F90 index b654a0657..a9e6d1839 100644 --- a/physics/rrtmgp_lw_rte.F90 +++ b/physics/rrtmgp_lw_rte.F90 @@ -29,7 +29,7 @@ end subroutine rrtmgp_lw_rte_init !! \htmlinclude rrtmgp_lw_rte_run.html !! subroutine rrtmgp_lw_rte_run(doLWrad, doLWclrsky, use_LW_jacobian, doGP_lwscat, nCol, & - nLev, p_lev, sfc_emiss_byband, sources, lw_optical_props_clrsky, & + nLev, p_lev, sfc_emiss_byband, sources, lw_optical_props_clrsky, & lw_optical_props_clouds, lw_optical_props_aerosol, nGauss_angles, fluxlwUP_allsky, & fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, sfculw_jac, errmsg, errflg) diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 1b0500650..44b5e0510 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -207,7 +207,6 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, ! ! ####################################################################################### #ifdef MPI - call mpi_barrier(mpicomm, mpierr) if (mpirank .eq. mpiroot) then #endif if (doGP_cldoptics_LUT) then @@ -356,30 +355,23 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, ! ! ####################################################################################### if (doGP_cldoptics_LUT) then -!$omp critical (load_sw_cloud_props_LUTs) call check_error_msg('sw_cloud_optics_init',sw_cloud_props%load(band_limsCLDSW, & radliq_lwrSW, radliq_uprSW, radliq_facSW, radice_lwrSW, radice_uprSW, & radice_facSW, lut_extliqSW, lut_ssaliqSW, lut_asyliqSW, lut_exticeSW, & lut_ssaiceSW, lut_asyiceSW)) -!$omp end critical (load_sw_cloud_props_LUTs) endif if (doGP_cldoptics_PADE) then -!$omp critical (load_sw_cloud_props_PADE_approx) call check_error_msg('sw_cloud_optics_init', sw_cloud_props%load(band_limsCLDSW, & pade_extliqSW, pade_ssaliqSW, pade_asyliqSW, pade_exticeSW, pade_ssaiceSW, & pade_asyiceSW, pade_sizereg_extliqSW, pade_sizereg_ssaliqSW, & pade_sizereg_asyliqSW, pade_sizereg_exticeSW, pade_sizereg_ssaiceSW, & pade_sizereg_asyiceSW)) -!$omp end critical (load_sw_cloud_props_PADE_approx) endif -!$omp critical (load_sw_cloud_props_nrghice) call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(nrghice_fromfileSW)) -!$omp end critical (load_sw_cloud_props_nrghice) ! Initialize coefficients for rain and snow(+groupel) cloud optics -!$omp critical (load_sw_precip_props) allocate(b0r(sw_cloud_props%get_nband()),b0s(sw_cloud_props%get_nband()), & b1s(sw_cloud_props%get_nband()),c0r(sw_cloud_props%get_nband()), & c0s(sw_cloud_props%get_nband())) @@ -393,7 +385,6 @@ subroutine rrtmgp_sw_cloud_optics_init(doG_cldoptics, doGP_cldoptics_PADE, 0.944, 0.894, 0.884, 0.883, 0.883, 0.883, 0.883/) c0s = (/0.970, 0.970, 0.970, 0.970, 0.970, 0.970, 0.970, & 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/) -!$omp end critical (load_sw_precip_props) end subroutine rrtmgp_sw_cloud_optics_init diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 2d8afdc14..30452869d 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -265,7 +265,6 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! ! ####################################################################################### #ifdef MPI - call mpi_barrier(mpicomm, mpierr) if (mpirank .eq. mpiroot) then #endif write (*,*) 'Reading RRTMGP shortwave k-distribution data ... ' @@ -455,7 +454,6 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, ! Initialize RRTMGP DDT's... ! ! ####################################################################################### -!$omp critical (load_sw_gas_optics) gas_concentrations%gas_name(:) = active_gases_array(:) call check_error_msg('sw_gas_optics_init',sw_gas_props%load(gas_concentrations, & gas_namesSW, key_speciesSW, band2gptSW, band_limsSW, press_refSW, press_ref_tropSW,& @@ -467,7 +465,6 @@ subroutine rrtmgp_sw_gas_optics_init(nCol, nLev, nThreads, rrtmgp_root_dir, scale_by_complement_upperSW, kminor_start_lowerSW, kminor_start_upperSW, & solar_quietSW, solar_facularSW, solar_sunspotSW, tsi_defaultSW, mg_defaultSW, & sb_defaultSW, rayl_lowerSW, rayl_upperSW)) -!$omp end critical (load_sw_gas_optics) end subroutine rrtmgp_sw_gas_optics_init From 2a39342614d0892273bc7ac829825f17bfb02f36 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 23 Feb 2021 18:33:47 +0000 Subject: [PATCH 11/12] Fixed whitespace. --- physics/rrtmgp_sw_cloud_sampling.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index b969c50a9..40a6bf6e0 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -45,7 +45,7 @@ end subroutine rrtmgp_sw_cloud_sampling_init subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, ipsdsw0, idxday, iovr, & iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, & icseed_sw, cld_frac, precip_frac, cloud_overlap_param, precip_overlap_param, & - sw_optical_props_cloudsByBand, sw_optical_props_precipByBand, & + sw_optical_props_cloudsByBand, sw_optical_props_precipByBand, & sw_optical_props_clouds, sw_optical_props_precip, errmsg, errflg) ! Inputs From f21573135c977807cd9e4060ec675b757348bc92 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 23 Feb 2021 22:39:25 +0000 Subject: [PATCH 12/12] Remove mpi_bcast for unallocated fields. --- physics/rrtmgp_lw_gas_optics.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index 7f746b8f3..ac3a8d7f0 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -388,10 +388,6 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, size(kminor_lowerLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(kminor_upperLW, & size(kminor_upperLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call mpi_bcast(rayl_lowerLW, & - size(rayl_lowerLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call mpi_bcast(rayl_upperLW, & - size(rayl_upperLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(kmajorLW, & size(kmajorLW), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) call mpi_bcast(planck_fracLW, &