From 6e2c8bdabcd53657852a1e905995131215ab5518 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 6 Jun 2019 10:24:02 -0600 Subject: [PATCH] Some cleaning up since last commit. --- physics/GFS_rrtmgp_lw_post.F90 | 7 +- physics/GFS_rrtmgp_post.F90 | 11 +-- physics/GFS_rrtmgp_pre.F90 | 2 +- physics/GFS_rrtmgp_sw_post.F90 | 2 +- physics/GFS_rrtmgp_sw_pre.F90 | 118 ------------------------ physics/rrtmgp_aux.F90 | 27 ++++++ physics/rrtmgp_lw_cloud_optics.F90 | 111 +++++++++++------------ physics/rrtmgp_lw_gas_optics.F90 | 138 +++++++++++++++-------------- physics/rrtmgp_sw.F90 | 3 +- physics/rrtmgp_sw_cloud_optics.F90 | 116 +++++++++++------------- physics/rrtmgp_sw_gas_optics.F90 | 135 ++++++++++++++-------------- physics/rrtmgp_sw_pre.F90 | 115 ------------------------ 12 files changed, 273 insertions(+), 512 deletions(-) delete mode 100644 physics/GFS_rrtmgp_sw_pre.F90 create mode 100644 physics/rrtmgp_aux.F90 delete mode 100644 physics/rrtmgp_sw_pre.F90 diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 index ab8c1b2e7..a9415a42f 100644 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ b/physics/GFS_rrtmgp_lw_post.F90 @@ -14,7 +14,7 @@ module GFS_rrtmgp_lw_post use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate - use rrtmgp_lw_gas_optics, only: check_error_msg + use rrtmgp_aux, only: check_error_msg implicit none public GFS_rrtmgp_lw_post_init,GFS_rrtmgp_lw_post_run,GFS_rrtmgp_lw_post_finalize @@ -42,7 +42,6 @@ end subroutine GFS_rrtmgp_lw_post_init !! | fluxlwDOWN_allsky | lw_flux_profile_downward_allsky | RRTMGP downward longwave all-sky flux profile | W m-2 | 2 | real | kind_phys | in | F | !! | fluxlwUP_clrsky | lw_flux_profile_upward_clrsky | RRTMGP upward longwave clr-sky flux profile | W m-2 | 2 | real | kind_phys | in | F | !! | fluxlwDOWN_clrsky | lw_flux_profile_downward_clrsky | RRTMGP downward longwave clr-sky flux profile | W m-2 | 2 | real | kind_phys | in | F | -!! | lw_gas_props | coefficients_for_lw_gas_optics | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | in | F | !! | hlwc | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step | longwave total sky heating rate | K s-1 | 2 | real | kind_phys | out | F | !! | topflx_lw | lw_fluxes_top_atmosphere | longwave total sky fluxes at the top of the atm | W m-2 | 1 | topflw_type | | inout | F | !! | sfcflx_lw | lw_fluxes_sfc | longwave total sky fluxes at the Earth surface | W m-2 | 1 | sfcflw_type | | inout | F | @@ -53,7 +52,7 @@ end subroutine GFS_rrtmgp_lw_post_init !! #endif subroutine GFS_rrtmgp_lw_post_run (Model, Grid, Diag, Radtend, Statein, & - Coupling, im, p_lev, lw_gas_props, & + Coupling, im, p_lev, & tsfa, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, & hlwc, topflx_lw, sfcflx_lw, flxprf_lw, hlw0, errmsg, errflg) @@ -74,8 +73,6 @@ subroutine GFS_rrtmgp_lw_post_run (Model, Grid, Diag, Radtend, Statein, & im ! Horizontal loop extent real(kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: & tsfa ! Lowest model layer air temperature for radiation - type(ty_gas_optics_rrtmgp),intent(in) :: & - lw_gas_props ! DDT containing LW spectral information real(kind_phys), dimension(size(Grid%xlon,1), Model%levs+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (hPa) real(kind_phys), dimension(size(Grid%xlon,1), Model%levs+1), intent(in) :: & diff --git a/physics/GFS_rrtmgp_post.F90 b/physics/GFS_rrtmgp_post.F90 index 020f37c86..ce18c8880 100644 --- a/physics/GFS_rrtmgp_post.F90 +++ b/physics/GFS_rrtmgp_post.F90 @@ -221,14 +221,5 @@ end subroutine GFS_rrtmgp_post_run subroutine GFS_rrtmgp_post_finalize () end subroutine GFS_rrtmgp_post_finalize - subroutine check_error_msg(routine_name, error_msg) - character(len=*), intent(in) :: & - error_msg, routine_name - - if(error_msg /= "") then - print*,"ERROR("//trim(routine_name)//"): " - print*,trim(error_msg) - return - end if - end subroutine check_error_msg + end module GFS_rrtmgp_post diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 85b151bc2..5dcd9a199 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -54,7 +54,7 @@ module GFS_rrtmgp_pre ! RRTMGP types use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_gas_concentrations, only: ty_gas_concs - use rrtmgp_lw_gas_optics, only: check_error_msg + use rrtmgp_aux, only: check_error_msg real(kind_phys), parameter :: & amd = 28.9644_kind_phys, & ! Molecular weight of dry-air (g/mol) diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index a804a2e01..122ce3f44 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -14,7 +14,7 @@ module GFS_rrtmgp_sw_post use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_fluxes_byband, only: ty_fluxes_byband use mo_heating_rates, only: compute_heating_rate - use rrtmgp_sw_gas_optics, only: check_error_msg + use rrtmgp_aux, only: check_error_msg implicit none public GFS_rrtmgp_sw_post_init,GFS_rrtmgp_sw_post_run,GFS_rrtmgp_sw_post_finalize diff --git a/physics/GFS_rrtmgp_sw_pre.F90 b/physics/GFS_rrtmgp_sw_pre.F90 deleted file mode 100644 index 3ca2c3910..000000000 --- a/physics/GFS_rrtmgp_sw_pre.F90 +++ /dev/null @@ -1,118 +0,0 @@ -!>\file GFS_rrtmgp_sw_pre.f90 -!! This file contains a subroutine to module_radiation_surface::setalb() to -!! setup surface albedo for SW radiation. - module GFS_rrtmgp_sw_pre - contains - -!>\defgroup GFS_rrtmgp_sw_pre GFS RRTMGP scheme Pre -!! @{ -!> \section arg_table_GFS_rrtmgp_sw_pre_init Argument Table -!! - subroutine GFS_rrtmgp_sw_pre_init () - end subroutine GFS_rrtmgp_sw_pre_init - -!> \section arg_table_GFS_rrtmgp_sw_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------|--------------------------------------------------------------------|----------|------|------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | in | F | -!! | Grid | GFS_grid_type_instance | Fortran DDT containing FV3-GFS grid and interpolation related data | DDT | 0 | GFS_grid_type | | in | F | -!! | Sfcprop | GFS_sfcprop_type_instance | Fortran DDT containing FV3-GFS surface fields | DDT | 0 | GFS_sfcprop_type | | in | F | -!! | Radtend | GFS_radtend_type_instance | Fortran DDT containing FV3-GFS radiation tendencies | DDT | 0 | GFS_radtend_type | | inout | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | nday | daytime_points_dimension | daytime points dimension | count | 0 | integer | | out | F | -!! | idxday | daytime_points | daytime points | index | 1 | integer | | out | F | -!! | tsfg | surface_ground_temperature_for_radiation | surface ground temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | tsfa | surface_air_temperature_for_radiation | lowest model layer air temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | sfcalb1 | surface_albedo_due_to_near_IR_direct | surface albedo due to near IR direct beam | frac | 1 | real | kind_phys | out | F | -!! | sfcalb2 | surface_albedo_due_to_near_IR_diffused | surface albedo due to near IR diffused beam | frac | 1 | real | kind_phys | out | F | -!! | sfcalb3 | surface_albedo_due_to_UV_and_VIS_direct | surface albedo due to UV+VIS direct beam | frac | 1 | real | kind_phys | out | F | -!! | sfcalb4 | surface_albedo_due_to_UV_and_VIS_diffused | surface albedo due to UV+VIS diffused beam | frac | 1 | real | kind_phys | out | F | -!! | alb1d | surface_albedo_perturbation | surface albedo perturbation | frac | 1 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_rrtmgp_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & - nday, idxday, tsfg, tsfa, sfcalb1, sfcalb2, sfcalb3, sfcalb4, & - alb1d, errmsg, errflg) - - use machine, only: kind_phys - - use GFS_typedefs, only: GFS_control_type, & - GFS_grid_type, & - GFS_radtend_type, & - GFS_sfcprop_type - use module_radiation_surface, only: NF_ALBD, setalb - - implicit none - - type(GFS_control_type), intent(in) :: Model - type(GFS_radtend_type), intent(inout) :: Radtend - type(GFS_sfcprop_type), intent(in) :: Sfcprop - type(GFS_grid_type), intent(in) :: Grid - integer, intent(in) :: im - integer, intent(out) :: nday - integer, dimension(size(Grid%xlon,1)), intent(out) :: idxday - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: sfcalb1, sfcalb2, sfcalb3, sfcalb4 - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: alb1d - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Local variables - integer :: i - real(kind=kind_phys), dimension(size(Grid%xlon,1),NF_ALBD) :: sfcalb - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! --- ... start radiation calculations -! remember to set heating rate unit to k/sec! -!> -# Start SW radiation calculations - if (Model%lsswr) then - -!> - Check for daytime points for SW radiation. - nday = 0 - idxday = 0 - do i = 1, IM - if (Radtend%coszen(i) >= 0.0001) then - nday = nday + 1 - idxday(nday) = i - endif - enddo - -!> - Call module_radiation_surface::setalb() to setup surface albedo. -!! for SW radiation. - - call setalb (Sfcprop%slmsk, Sfcprop%snowd, Sfcprop%sncovr,& ! --- inputs: - Sfcprop%snoalb, Sfcprop%zorl, Radtend%coszen,& - tsfg, tsfa, Sfcprop%hprim, Sfcprop%alvsf, & - Sfcprop%alnsf, Sfcprop%alvwf, Sfcprop%alnwf, & - Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, & - Sfcprop%tisfc, IM, & - alb1d, Model%pertalb, & ! mg, sfc-perts - sfcalb) ! --- outputs - -!> -# Approximate mean surface albedo from vis- and nir- diffuse values. - Radtend%sfalb(:) = max(0.01, 0.5 * (sfcalb(:,2) + sfcalb(:,4))) - else - nday = 0 - idxday = 0 - sfcalb = 0.0 - endif - - do i = 1, im - sfcalb1(i) = sfcalb(i,1) - sfcalb2(i) = sfcalb(i,2) - sfcalb3(i) = sfcalb(i,3) - sfcalb4(i) = sfcalb(i,4) - enddo - - end subroutine GFS_rrtmgp_sw_pre_run - -!> \section arg_table_GFS_rrtmgp_sw_pre_finalize Argument Table -!! - subroutine GFS_rrtmgp_sw_pre_finalize () - end subroutine GFS_rrtmgp_sw_pre_finalize - -!! @} - end module GFS_rrtmgp_sw_pre diff --git a/physics/rrtmgp_aux.F90 b/physics/rrtmgp_aux.F90 new file mode 100644 index 000000000..2df87992f --- /dev/null +++ b/physics/rrtmgp_aux.F90 @@ -0,0 +1,27 @@ +module rrtmgp_aux + implicit none +contains + ! + subroutine rrtmgp_aux_init() + end subroutine rrtmgp_aux_init + ! + subroutine rrtmgp_aux_run() + end subroutine rrtmgp_aux_run + ! + subroutine rrtmgp_aux_finalize() + end subroutine rrtmgp_aux_finalize + + ! ######################################################################################### + ! SUBROUTINE check_error_msg + ! ######################################################################################### + subroutine check_error_msg(routine_name, error_msg) + character(len=*), intent(in) :: & + error_msg, routine_name + + if(error_msg /= "") then + print*,"ERROR("//trim(routine_name)//"): " + print*,trim(error_msg) + return + end if + end subroutine check_error_msg +end module rrtmgp_aux diff --git a/physics/rrtmgp_lw_cloud_optics.F90 b/physics/rrtmgp_lw_cloud_optics.F90 index 2434e025f..884101046 100644 --- a/physics/rrtmgp_lw_cloud_optics.F90 +++ b/physics/rrtmgp_lw_cloud_optics.F90 @@ -9,10 +9,9 @@ module rrtmgp_lw_cloud_optics use mo_cloud_sampling, only: sampled_mask_max_ran, sampled_mask_exp_ran, draw_samples use mersenne_twister, only: random_setseed, random_number, random_stat use mo_rrtmg_lw_cloud_optics, only: rrtmg_lw_cloud_optics - use rrtmgp_lw_gas_optics, only: ipsdlw0 + use rrtmgp_aux, only: check_error_msg use netcdf - integer :: nrghice_lw public rrtmgp_lw_cloud_optics_init, rrtmgp_lw_cloud_optics_run, rrtmgp_lw_cloud_optics_finalize contains @@ -54,46 +53,47 @@ subroutine rrtmgp_lw_cloud_optics_init(Model, mpicomm, mpirank, mpiroot, lw_clou ! Variables that will be passed to cloud_optics%load() real(kind_phys) :: & - radliq_lwr, & ! used by RRTMGP cloud optics - radliq_upr, & ! used by RRTMGP cloud optics - radliq_fac, & ! used by RRTMGP cloud optics - radice_lwr, & ! used by RRTMGP cloud optics - radice_upr, & ! used by RRTMGP cloud optics - radice_fac ! used by RRTMGP cloud optics + radliq_lwr, & ! + radliq_upr, & ! + radliq_fac, & ! + radice_lwr, & ! + radice_upr, & ! + radice_fac ! real(kind_phys), dimension(:), allocatable :: & - pade_sizereg_extliq, & ! used by RRTMGP cloud optics - pade_sizereg_ssaliq, & ! used by RRTMGP cloud optics - pade_sizereg_asyliq, & ! used by RRTMGP cloud optics - pade_sizereg_extice, & ! used by RRTMGP cloud optics - pade_sizereg_ssaice, & ! used by RRTMGP cloud optics - pade_sizereg_asyice ! used by RRTMGP cloud optics + pade_sizereg_extliq, & ! + pade_sizereg_ssaliq, & ! + pade_sizereg_asyliq, & ! + pade_sizereg_extice, & ! + pade_sizereg_ssaice, & ! + pade_sizereg_asyice ! real(kind_phys), dimension(:,:), allocatable :: & - lut_extliq, & ! used by RRTMGP cloud optics - lut_ssaliq, & ! used by RRTMGP cloud optics - lut_asyliq, & ! used by RRTMGP cloud optics - band_lims_cldy ! used by RRTMGP cloud optics + lut_extliq, & ! + lut_ssaliq, & ! + lut_asyliq, & ! + band_lims_cldy ! real(kind_phys), dimension(:,:,:), allocatable :: & - lut_extice, & ! used by RRTMGP cloud optics - lut_ssaice, & ! used by RRTMGP cloud optics - lut_asyice, & ! used by RRTMGP cloud optics - pade_extliq, & ! used by RRTMGP cloud optics - pade_ssaliq, & ! used by RRTMGP cloud optics - pade_asyliq ! used by RRTMGP cloud optics + lut_extice, & ! + lut_ssaice, & ! + lut_asyice, & ! + pade_extliq, & ! + pade_ssaliq, & ! + pade_asyliq ! real(kind_phys), dimension(:,:,:,:), allocatable :: & - pade_extice, & ! used by RRTMGP cloud optics - pade_ssaice, & ! used by RRTMGP cloud optics - pade_asyice ! used by RRTMGP cloud optics + pade_extice, & ! + pade_ssaice, & ! + pade_asyice ! ! Dimensions integer :: & - nbandLWcldy, & ! used by RRTMGP cloud optics - nsize_liq, & ! used by RRTMGP cloud optics - nsize_ice, & ! used by RRTMGP cloud optics - nsizereg, & ! used by RRTMGP cloud optics - ncoeff_ext, & ! used by RRTMGP cloud optics - ncoeff_ssa_g, & ! used by RRTMGP cloud optics - nbound, & ! used by RRTMGP cloud optics - npairsLWcldy ! used by RRTMGP cloud optics + nrghice_lw, & ! Number of ice-roughness categories in file + nbandLWcldy, & ! + nsize_liq, & ! + nsize_ice, & ! + nsizereg, & ! + ncoeff_ext, & ! + ncoeff_ssa_g, & ! + nbound, & ! + npairsLWcldy ! ! Local variables integer :: dimID,varID,status,igpt,iGas,ij,ierr,ncid_lw_clds @@ -133,6 +133,11 @@ subroutine rrtmgp_lw_cloud_optics_init(Model, mpicomm, mpirank, mpiroot, lw_clou endif endif + ! Check to ensure that number of ice-roughness categories is feasible. + if (Model%rrtmgp_nrghice .gt. nrghice_lw) then + errmsg = 'Number of RRTMGP ice-roughness categories requested in namelist file is not allowed' + endif + ! Broadcast dimensions to all processors #ifdef MPI if (Model%rrtmgp_cld_optics .eq. 1 .or. Model%rrtmgp_cld_optics .eq. 2) then @@ -290,14 +295,13 @@ subroutine rrtmgp_lw_cloud_optics_init(Model, mpicomm, mpirank, mpiroot, lw_clou #endif ! Load tables data for RRTMGP cloud-optics + call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(Model%rrtmgp_nrghice)) if (Model%rrtmgp_cld_optics .eq. 1) then - call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(nrghice_lw)) call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_lims_cldy, & radliq_lwr, radliq_upr, radliq_fac, radice_lwr, radice_upr, radice_fac, & lut_extliq, lut_ssaliq, lut_asyliq, lut_extice, lut_ssaice, lut_asyice)) endif if (Model%rrtmgp_cld_optics .eq. 2) then - call check_error_msg('lw_cloud_optics_init',lw_cloud_props%set_ice_roughness(nrghice_lw)) call check_error_msg('lw_cloud_optics_init',lw_cloud_props%load(band_lims_cldy, & pade_extliq, pade_ssaliq, pade_asyliq, pade_extice, pade_ssaice, & pade_asyice, pade_sizereg_extliq, pade_sizereg_ssaliq, pade_sizereg_asyliq,& @@ -311,7 +315,6 @@ end subroutine rrtmgp_lw_cloud_optics_init !! |-----------------------|-----------------------------------------------------|------------------------------------------------------------------------------|---------|------|-----------------------|-----------|--------|----------| !! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | in | F | !! | ncol | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | -!! | ngpts_lw | number_of_spectral_points_for_LW_calculation | Number of spectral points for LW RRTMGP calculation | none | 0 | integer | | in | F | !! | p_lay | air_pressure_at_layer_for_RRTMGP_in_hPa | air pressure layer | hPa | 2 | real | kind_phys | in | F | !! | t_lay | air_temperature_at_layer_for_RRTMGP | air temperature layer | K | 2 | real | kind_phys | in | F | !! | p_lev | air_pressure_at_interface_for_RRTMGP_in_hPa | air pressure level | hPa | 2 | real | kind_phys | in | F | @@ -328,6 +331,7 @@ end subroutine rrtmgp_lw_cloud_optics_init !! | aerosols | aerosol_optical_properties_for_longwave_bands_01-16 | aerosol optical properties for longwave bands 01-16 | various | 4 | real | kind_phys | in | F | !! | lw_cloud_props | coefficients_for_lw_cloud_optics | DDT containing spectral information for cloudy RRTMGP LW radiation scheme | DDT | 0 | ty_cloud_optics | | in | F | !! | lw_gas_props | coefficients_for_lw_gas_optics | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | in | F | +!! | ipsdlw0 | initial_permutation_seed_lw | initial seed for McICA LW | none | 0 | integer | | in | F | !! | optical_props_clouds | longwave_optical_properties_for_cloudy_atmosphere | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_1scl | | out | F | !! | optical_props_aerosol | longwave_optical_properties_for_aerosols | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_1scl | | out | F | !! | cldtaulw | cloud_optical_depth_layers_at_10mu_band | approx 10mu band layer cloud optical depth | none | 2 | real | kind_phys | out | F | @@ -337,9 +341,9 @@ end subroutine rrtmgp_lw_cloud_optics_init ! ######################################################################################### ! SUBROUTINE rrtmgp_lw_cloud_optics_run() ! ######################################################################################### - subroutine rrtmgp_lw_cloud_optics_run(Model, ncol, ngpts_lw, icseed_lw, p_lay, t_lay, p_lev, cld_frac, & + subroutine rrtmgp_lw_cloud_optics_run(Model, ncol, icseed_lw, p_lay, t_lay, p_lev, cld_frac, & cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & - aerosols, lw_cloud_props, lw_gas_props, & + aerosols, lw_cloud_props, lw_gas_props, ipsdlw0, & optical_props_clouds, optical_props_aerosol, cldtaulw, errmsg, errflg) ! Inputs @@ -347,7 +351,7 @@ subroutine rrtmgp_lw_cloud_optics_run(Model, ncol, ngpts_lw, icseed_lw, p_lay, t Model ! DDT containing FV3-GFS model control parameters integer, intent(in) :: & ncol, & ! Number of horizontal gridpoints - ngpts_lw ! Number of spectral points + ipsdlw0 ! Initial permutation seed for McICA integer,intent(in),dimension(ncol) :: & icseed_lw ! auxiliary special cloud related array when module ! variable isubclw=2, it provides permutation seed @@ -392,9 +396,9 @@ subroutine rrtmgp_lw_cloud_optics_run(Model, ncol, ngpts_lw, icseed_lw, p_lay, t logical,dimension(ncol,model%levs) :: liqmask, icemask type(ty_optical_props_1scl) :: optical_props_cloudsByBand type(random_stat) :: rng_stat - real(kind_phys), dimension(ngpts_lw,model%levs,ncol) :: rng3D - real(kind_phys), dimension(ngpts_lw*model%levs) :: rng1D - logical, dimension(ncol,model%levs,ngpts_lw) :: cldfracMCICA + real(kind_phys), dimension(lw_gas_props%get_ngpt(),model%levs,ncol) :: rng3D + real(kind_phys), dimension(lw_gas_props%get_ngpt()*model%levs) :: rng1D + logical, dimension(ncol,model%levs,lw_gas_props%get_ngpt()) :: cldfracMCICA real(kind_phys), dimension(ncol,model%levs,lw_cloud_props%get_nband()) :: & tau_cld @@ -450,7 +454,7 @@ subroutine rrtmgp_lw_cloud_optics_run(Model, ncol, ngpts_lw, icseed_lw, p_lay, t ncol, & ! IN - Number of horizontal gridpoints model%levs, & ! IN - Number of vertical layers lw_cloud_props%get_nband(), & ! IN - Number of LW bands - nrghice_lw, & ! IN - Number of ice-roughness categories + Model%rrtmgp_nrghice, & ! IN - Number of ice-roughness categories liqmask, & ! IN - Liquid-cloud mask icemask, & ! IN - Ice-cloud mask cld_lwp, & ! IN - Cloud liquid water path @@ -477,7 +481,7 @@ subroutine rrtmgp_lw_cloud_optics_run(Model, ncol, ngpts_lw, icseed_lw, p_lay, t do iCol=1,ncol call random_setseed(ipseed_lw(icol),rng_stat) call random_number(rng1D,rng_stat) - rng3D(:,:,iCol) = reshape(source = rng1D,shape=[ngpts_lw,model%levs]) + rng3D(:,:,iCol) = reshape(source = rng1D,shape=[lw_gas_props%get_ngpt(),model%levs]) enddo ! Call McICA @@ -500,19 +504,4 @@ end subroutine rrtmgp_lw_cloud_optics_run ! ######################################################################################### subroutine rrtmgp_lw_cloud_optics_finalize() end subroutine rrtmgp_lw_cloud_optics_finalize - - ! ######################################################################################### - ! SUBROUTINE check_error_msg - ! ######################################################################################### - subroutine check_error_msg(routine_name, error_msg) - character(len=*), intent(in) :: & - error_msg, routine_name - - if(error_msg /= "") then - print*,"ERROR("//trim(routine_name)//"): " - print*,trim(error_msg) - return - end if - end subroutine check_error_msg - end module rrtmgp_lw_cloud_optics diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index 1cbe878ae..2e28b59be 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -3,13 +3,18 @@ module rrtmgp_lw_gas_optics use GFS_typedefs, only: GFS_control_type, GFS_radtend_type use mo_rte_kind, only: wl use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_gas_concentrations, only: ty_gas_concs + use mo_gas_concentrations, only: ty_gas_concs + use rrtmgp_aux, only: check_error_msg use netcdf ! Parameters - integer :: ipsdlw0 + contains + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_gas_optics_init + ! ######################################################################################### !! \section arg_table_rrtmgp_lw_gas_optics_init Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |--------------|----------------------------------------------|--------------------------------------------------------------------|-------|------|----------------------|-------|--------|----------| @@ -20,13 +25,11 @@ module rrtmgp_lw_gas_optics !! | mpicomm | mpi_comm | MPI communicator | index | 0 | integer | | in | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! | ipsdlw0 | initial_permutation_seed_lw | initial seed for McICA LW | none | 0 | integer | | out | F | !! | lw_gas_props | coefficients_for_lw_gas_optics | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | out | F | -!! | ngpts_lw | number_of_spectral_points_for_LW_calculation | Number of spectral points for LW RRTMGP calculation | none | 0 | integer | | out | F | !! - ! ######################################################################################### - ! ######################################################################################### subroutine rrtmgp_lw_gas_optics_init(Model, Radtend, mpicomm, mpirank, mpiroot, lw_gas_props, & - ngpts_lw, errmsg, errflg) + ipsdlw0, errmsg, errflg) use netcdf #ifdef MPI @@ -47,9 +50,8 @@ subroutine rrtmgp_lw_gas_optics_init(Model, Radtend, mpicomm, mpirank, mpiroot, character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & - errflg ! Error code - integer, intent(out) :: & - ngpts_lw ! Number of g-points + errflg, & ! Error code + ipsdlw0 type(ty_gas_optics_rrtmgp),intent(out) :: & lw_gas_props ! DDT containing spectral information for RRTMGP LW radiation scheme @@ -57,63 +59,64 @@ subroutine rrtmgp_lw_gas_optics_init(Model, Radtend, mpicomm, mpirank, mpiroot, type(ty_gas_concs) :: & gas_concentrations integer, dimension(:), allocatable :: & - kminor_start_lower, & ! used by RRTMGP gas optics - kminor_start_upper ! used by RRTMGP gas optics + kminor_start_lower, & ! + kminor_start_upper ! integer, dimension(:,:), allocatable :: & - band2gpt, & ! used by RRTMGP gas optics - minor_limits_gpt_lower, & ! used by RRTMGP gas optics - minor_limits_gpt_upper ! used by RRTMGP gas optics + band2gpt, & ! + minor_limits_gpt_lower, & ! + minor_limits_gpt_upper ! integer, dimension(:,:,:), allocatable :: & - key_species ! used by RRTMGP gas optics + key_species ! real(kind_phys) :: & - press_ref_trop, & ! used by RRTMGP gas optics - temp_ref_p, & ! used by RRTMGP gas optics - temp_ref_t ! used by RRTMGP gas optics + press_ref_trop, & ! + temp_ref_p, & ! + temp_ref_t ! real(kind_phys), dimension(:), allocatable :: & - press_ref, & ! used by RRTMGP gas optics - temp_ref ! used by RRTMGP gas optics + press_ref, & ! + temp_ref ! real(kind_phys), dimension(:,:), allocatable :: & - band_lims, & ! used by RRTMGP gas optics - totplnk ! used by RRTMGP gas optics + band_lims, & ! + totplnk ! real(kind_phys), dimension(:,:,:), allocatable :: & - vmr_ref, & ! used by RRTMGP gas optics - kminor_lower, & ! used by RRTMGP gas optics - kminor_upper, & ! used by RRTMGP gas optics - rayl_lower, & ! used by RRTMGP gas optics - rayl_upper ! used by RRTMGP gas optics + vmr_ref, & ! + kminor_lower, & ! + kminor_upper, & ! + rayl_lower, & ! + rayl_upper ! real(kind_phys), dimension(:,:,:,:), allocatable :: & - kmajor, & ! used by RRTMGP gas optics - planck_frac ! used by RRTMGP gas optics + kmajor, & ! + planck_frac ! character(len=32), dimension(:), allocatable :: & - gas_names, & ! used by RRTMGP gas optics - gas_minor, & ! used by RRTMGP gas optics - identifier_minor, & ! used by RRTMGP gas optics - minor_gases_lower, & ! used by RRTMGP gas optics - minor_gases_upper, & ! used by RRTMGP gas optics - scaling_gas_lower, & ! used by RRTMGP gas optics - scaling_gas_upper ! used by RRTMGP gas optics + gas_names, & ! + gas_minor, & ! + identifier_minor, & ! + minor_gases_lower, & ! + minor_gases_upper, & ! + scaling_gas_lower, & ! + scaling_gas_upper ! logical(wl), dimension(:), allocatable :: & - minor_scales_with_density_lower, & ! used by RRTMGP gas optics - minor_scales_with_density_upper, & ! used by RRTMGP gas optics - scale_by_complement_lower, & ! used by RRTMGP gas optics - scale_by_complement_upper ! used by RRTMGP gas optics + minor_scales_with_density_lower, & ! + minor_scales_with_density_upper, & ! + scale_by_complement_lower, & ! + scale_by_complement_upper ! ! Dimensions (to be broadcast across all processors) integer :: & - ntemps, & ! used by RRTMGP gas optics - npress, & ! used by RRTMGP gas optics - nabsorbers, & ! used by RRTMGP gas optics - nextrabsorbers, & ! used by RRTMGP gas optics - nminorabsorbers, & ! used by RRTMGP gas optics - nmixingfracs, & ! used by RRTMGP gas optics - nlayers, & ! used by RRTMGP gas optics - nbnds, & ! used by RRTMGP gas optics - npairs, & ! used by RRTMGP gas optics - ninternalSourcetemps, & ! used by RRTMGP gas optics - nminor_absorber_intervals_lower, & ! used by RRTMGP gas optics - nminor_absorber_intervals_upper, & ! used by RRTMGP gas optics - ncontributors_lower, & ! used by RRTMGP gas optics - ncontributors_upper ! used by RRTMGP gas optics + ntemps, & ! + npress, & ! + ngpts_lw, & ! + nabsorbers, & ! + nextrabsorbers, & ! + nminorabsorbers, & ! + nmixingfracs, & ! + nlayers, & ! + nbnds, & ! + npairs, & ! + ninternalSourcetemps, & ! + nminor_absorber_intervals_lower, & ! + nminor_absorber_intervals_upper, & ! + ncontributors_lower, & ! + ncontributors_upper ! ! Local variables integer :: ncid_lw,dimID,varID,status,igpt,iGas,ij,ierr @@ -409,22 +412,21 @@ subroutine rrtmgp_lw_gas_optics_init(Model, Radtend, mpicomm, mpirank, mpiroot, ipsdlw0 = lw_gas_props%get_ngpt() end subroutine rrtmgp_lw_gas_optics_init + ! ######################################################################################### + ! SUBROUTINE rrtmgp_lw_gas_optics_run + ! *NOTE* The computation of the optical properties for a gaseous (+aerosols) atmosphere are + ! handled internally by the rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90:rte_sw() + ! driver. + ! If calling rte/mo_rte_sw.F90:rte_sw() directly, place calls to compute source + ! function and gas_optics() here. + ! ######################################################################################### subroutine rrtmgp_lw_gas_optics_run() end subroutine rrtmgp_lw_gas_optics_run - subroutine rrtmgp_lw_gas_optics_finalize() - end subroutine rrtmgp_lw_gas_optics_finalize - ! ######################################################################################### - ! SUBROUTINE check_error_msg ! ######################################################################################### - subroutine check_error_msg(routine_name, error_msg) - character(len=*), intent(in) :: & - error_msg, routine_name - - if(error_msg /= "") then - print*,"ERROR("//trim(routine_name)//"): " - print*,trim(error_msg) - return - end if - end subroutine check_error_msg + ! SUBROUTINE rrtmgp_lw_gas_optics_finalize + ! ######################################################################################### + subroutine rrtmgp_lw_gas_optics_finalize() + end subroutine rrtmgp_lw_gas_optics_finalize + end module rrtmgp_lw_gas_optics diff --git a/physics/rrtmgp_sw.F90 b/physics/rrtmgp_sw.F90 index 677113886..1f24190b7 100644 --- a/physics/rrtmgp_sw.F90 +++ b/physics/rrtmgp_sw.F90 @@ -12,7 +12,8 @@ module rrtmgp_sw use mo_fluxes_byband, only: ty_fluxes_byband use module_radsw_parameters, only: cmpfsw_type use rrtmgp_sw_cloud_optics, only: rrtmgp_sw_cloud_optics_init - use rrtmgp_sw_gas_optics, only: rrtmgp_sw_gas_optics_init, check_error_msg + use rrtmgp_sw_gas_optics, only: rrtmgp_sw_gas_optics_init + use rrtmgp_aux, only: check_error_msg public rrtmgp_sw_init, rrtmgp_sw_run, rrtmgp_sw_finalize diff --git a/physics/rrtmgp_sw_cloud_optics.F90 b/physics/rrtmgp_sw_cloud_optics.F90 index 809be4a77..58d62d50d 100644 --- a/physics/rrtmgp_sw_cloud_optics.F90 +++ b/physics/rrtmgp_sw_cloud_optics.F90 @@ -9,10 +9,9 @@ module rrtmgp_sw_cloud_optics use mo_cloud_sampling, only: sampled_mask_max_ran, sampled_mask_exp_ran, draw_samples use mersenne_twister, only: random_setseed, random_number, random_stat use mo_rrtmg_sw_cloud_optics, only: rrtmg_sw_cloud_optics - use rrtmgp_sw_gas_optics, only: ipsdsw0 + use rrtmgp_aux, only: check_error_msg use netcdf - integer :: nrghice_sw contains !! \section arg_table_rrtmgp_sw_cloud_optics_init Argument Table @@ -54,47 +53,48 @@ subroutine rrtmgp_sw_cloud_optics_init(Model,mpicomm, mpirank, mpiroot, sw_cloud ! Variables that will be passed to cloud_optics%load() real(kind_phys) :: & - radliq_lwr_sw, & ! used by RRTMGP cloud optics - radliq_upr_sw, & ! used by RRTMGP cloud optics - radliq_fac_sw, & ! used by RRTMGP cloud optics - radice_lwr_sw, & ! used by RRTMGP cloud optics - radice_upr_sw, & ! used by RRTMGP cloud optics - radice_fac_sw ! used by RRTMGP cloud optics + radliq_lwr_sw, & ! + radliq_upr_sw, & ! + radliq_fac_sw, & ! + radice_lwr_sw, & ! + radice_upr_sw, & ! + radice_fac_sw ! real(kind_phys), dimension(:), allocatable :: & - pade_sizereg_extliq_sw, & ! used by RRTMGP cloud optics - pade_sizereg_ssaliq_sw, & ! used by RRTMGP cloud optics - pade_sizereg_asyliq_sw, & ! used by RRTMGP cloud optics - pade_sizereg_extice_sw, & ! used by RRTMGP cloud optics - pade_sizereg_ssaice_sw, & ! used by RRTMGP cloud optics - pade_sizereg_asyice_sw ! used by RRTMGP cloud optics + pade_sizereg_extliq_sw, & ! + pade_sizereg_ssaliq_sw, & ! + pade_sizereg_asyliq_sw, & ! + pade_sizereg_extice_sw, & ! + pade_sizereg_ssaice_sw, & ! + pade_sizereg_asyice_sw ! real(kind_phys), dimension(:,:), allocatable :: & - lut_extliq_sw, & ! used by RRTMGP cloud optics - lut_ssaliq_sw, & ! used by RRTMGP cloud optics - lut_asyliq_sw, & ! used by RRTMGP cloud optics - band_lims_cldy_sw ! used by RRTMGP cloud optics + lut_extliq_sw, & ! + lut_ssaliq_sw, & ! + lut_asyliq_sw, & ! + band_lims_cldy_sw ! real(kind_phys), dimension(:,:,:), allocatable :: & - lut_extice_sw, & ! used by RRTMGP cloud optics - lut_ssaice_sw, & ! used by RRTMGP cloud optics - lut_asyice_sw, & ! used by RRTMGP cloud optics - pade_extliq_sw, & ! used by RRTMGP cloud optics - pade_ssaliq_sw, & ! used by RRTMGP cloud optics - pade_asyliq_sw ! used by RRTMGP cloud optics + lut_extice_sw, & ! + lut_ssaice_sw, & ! + lut_asyice_sw, & ! + pade_extliq_sw, & ! + pade_ssaliq_sw, & ! + pade_asyliq_sw ! real(kind_phys), dimension(:,:,:,:), allocatable :: & - pade_extice_sw, & ! used by RRTMGP cloud optics - pade_ssaice_sw, & ! used by RRTMGP cloud optics - pade_asyice_sw ! used by RRTMGP cloud optics + pade_extice_sw, & ! + pade_ssaice_sw, & ! + pade_asyice_sw ! ! Dimensions (to be broadcast across all processors) integer :: & - nbandSWcldy_sw, & ! used by RRTMGP cloud optics - nsize_liq_sw, & ! used by RRTMGP cloud optics - nsize_ice_sw, & ! used by RRTMGP cloud optics - nsizereg_sw, & ! used by RRTMGP cloud optics - ncoeff_ext_sw, & ! used by RRTMGP cloud optics - ncoeff_ssa_g_sw, & ! used by RRTMGP cloud optics - nbound_sw, & ! used by RRTMGP cloud optics - npairsSWcldy_sw ! used by RRTMGP cloud optics + nrghice_sw, & ! Number of ice-roughness categories in file + nbandSWcldy_sw, & ! + nsize_liq_sw, & ! + nsize_ice_sw, & ! + nsizereg_sw, & ! + ncoeff_ext_sw, & ! + ncoeff_ssa_g_sw, & ! + nbound_sw, & ! + npairsSWcldy_sw ! ! Local variables integer :: status,ncid_sw_clds,dimid,varID,iGas @@ -131,6 +131,11 @@ subroutine rrtmgp_sw_cloud_optics_init(Model,mpicomm, mpirank, mpiroot, sw_cloud status = nf90_close(ncid_sw_clds) endif endif + + ! Check to ensure that number of ice-roughness categories is feasible. + if (Model%rrtmgp_nrghice .gt. nrghice_sw) then + errmsg = 'Number of RRTMGP ice-roughness categories requested in namelist file is not allowed' + endif ! Broadcast dimensions to all processors #ifdef MPI @@ -289,15 +294,14 @@ subroutine rrtmgp_sw_cloud_optics_init(Model,mpicomm, mpirank, mpiroot, sw_cloud #endif ! Load tables data for RRTMGP cloud-optics + call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(Model%rrtmgp_nrghice)) if (Model%rrtmgp_cld_optics .eq. 1) then - call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(nrghice_sw)) call check_error_msg('sw_cloud_optics_init',sw_cloud_props%load(band_lims_cldy_sw, & radliq_lwr_sw, radliq_upr_sw, radliq_fac_sw, radice_lwr_sw, radice_upr_sw, & radice_fac_sw, lut_extliq_sw, lut_ssaliq_sw, lut_asyliq_sw, lut_extice_sw, & lut_ssaice_sw, lut_asyice_sw)) endif if (Model%rrtmgp_cld_optics .eq. 2) then - call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(nrghice_sw)) call check_error_msg('sw_cloud_optics_init', sw_cloud_props%load(band_lims_cldy_sw, & pade_extliq_sw, pade_ssaliq_sw, pade_asyliq_sw, pade_extice_sw, pade_ssaice_sw, & pade_asyice_sw, pade_sizereg_extliq_sw, pade_sizereg_ssaliq_sw, & @@ -311,7 +315,6 @@ end subroutine rrtmgp_sw_cloud_optics_init !! |-----------------------|------------------------------------------------------|------------------------------------------------------------------------------|---------|------|-----------------------|-----------|--------|----------| !! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | in | F | !! | ncol | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | -!! | ngpts_sw | number_of_spectral_points_for_SW_calculation | Number of spectral points for SW RRTMGP calculation | none | 0 | integer | | in | F | !! | p_lay | air_pressure_at_layer_for_RRTMGP_in_hPa | air pressure layer | hPa | 2 | real | kind_phys | in | F | !! | t_lay | air_temperature_at_layer_for_RRTMGP | air temperature layer | K | 2 | real | kind_phys | in | F | !! | p_lev | air_pressure_at_interface_for_RRTMGP_in_hPa | air pressure level | hPa | 2 | real | kind_phys | in | F | @@ -328,6 +331,7 @@ end subroutine rrtmgp_sw_cloud_optics_init !! | aerosols | aerosol_optical_properties_for_shortwave_bands_01-16 | aerosol optical properties for shortwave bands 01-16 | various | 4 | real | kind_phys | in | F | !! | sw_cloud_props | coefficients_for_sw_cloud_optics | DDT containing spectral information for cloudy RRTMGP SW radiation scheme | DDT | 0 | ty_cloud_optics | | in | F | !! | sw_gas_props | coefficients_for_sw_gas_optics | DDT containing spectral information for RRTMGP SW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | in | F | +!! | ipsdsw0 | initial_permutation_seed_sw | initial seed for McICA SW | none | 0 | integer | | in | F | !! | nday | daytime_points_dimension | daytime points dimension | count | 0 | integer | | in | F | !! | idxday | daytime_points | daytime points | index | 1 | integer | | in | F | !! | optical_props_clouds | shortwave_optical_properties_for_cloudy_atmosphere | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_2str | | out | F | @@ -339,9 +343,9 @@ end subroutine rrtmgp_sw_cloud_optics_init ! ######################################################################################### ! SUBROTUINE rrtmgp_sw_cloud_optics_run() ! ######################################################################################### - subroutine rrtmgp_sw_cloud_optics_run(Model, ncol, ngpts_sw, icseed_sw, p_lay, t_lay, p_lev, cld_frac, & ! IN + subroutine rrtmgp_sw_cloud_optics_run(Model, ncol, icseed_sw, p_lay, t_lay, p_lev, cld_frac, & ! IN cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, cld_rerain, & ! IN - aerosols, sw_cloud_props, sw_gas_props, nday, idxday, & ! IN + aerosols, sw_cloud_props, sw_gas_props, ipsdsw0, nday, idxday, & ! IN optical_props_clouds, optical_props_aerosol, cldtausw, errmsg, errflg) ! OUT ! Inputs @@ -350,7 +354,7 @@ subroutine rrtmgp_sw_cloud_optics_run(Model, ncol, ngpts_sw, icseed_sw, p_lay, t integer, intent(in) :: & ncol, & ! Number of horizontal gridpoints nday, & ! Number of daylit points. - ngpts_sw ! Number of spectral points + ipsdsw0 ! Initial permutation seed for McICA integer,intent(in),dimension(nday) :: & idxday ! Indices for daylit points. integer,intent(in),dimension(ncol) :: & @@ -395,9 +399,9 @@ subroutine rrtmgp_sw_cloud_optics_run(Model, ncol, ngpts_sw, icseed_sw, p_lay, t logical,dimension(ncol,model%levs) :: liqmask, icemask type(ty_optical_props_2str) :: optical_props_cloudsByBand type(random_stat) :: rng_stat - real(kind_phys), dimension(ngpts_sw,model%levs,ncol) :: rng3D - real(kind_phys), dimension(ngpts_sw*model%levs) :: rng1D - logical, dimension(ncol,model%levs,ngpts_sw) :: cldfracMCICA + real(kind_phys), dimension(sw_gas_props%get_ngpt(),model%levs,ncol) :: rng3D + real(kind_phys), dimension(sw_gas_props%get_ngpt()*model%levs) :: rng1D + logical, dimension(ncol,model%levs,sw_gas_props%get_ngpt()) :: cldfracMCICA real(kind_phys), dimension(nday,model%levs,sw_cloud_props%get_nband()) :: & tau_cld, ssa_cld, asy_cld @@ -435,7 +439,7 @@ subroutine rrtmgp_sw_cloud_optics_run(Model, ncol, ngpts_sw, icseed_sw, p_lay, t ! Aerosol optics [ncol,model%levs,nBands] call check_error_msg('rrtmgp_sw_cloud_optics_run',optical_props_aerosol%alloc_2str( & ncol, model%levs, sw_cloud_props%get_band_lims_wavenumber())) - ! Cloud optics [ncol,model%levs,nGpts] + ! Cloud optics [ncol,model%levs,nGpt] call check_error_msg('rrtmgp_sw_cloud_optics_run',optical_props_clouds%alloc_2str( & ncol, model%levs, sw_gas_props)) @@ -455,7 +459,7 @@ subroutine rrtmgp_sw_cloud_optics_run(Model, ncol, ngpts_sw, icseed_sw, p_lay, t ncol, & ! IN - Number of daylit gridpoints model%levs, & ! IN - Number of vertical layers sw_cloud_props%get_nband(), & ! IN - Number of SW bands - nrghice_sw, & ! IN - Number of ice-roughness categories + Model%rrtmgp_nrghice, & ! IN - Number of ice-roughness categories liqmask, & ! IN - Liquid-cloud mask icemask, & ! IN - Ice-cloud mask cld_lwp, & ! IN - Cloud liquid water path @@ -487,7 +491,7 @@ subroutine rrtmgp_sw_cloud_optics_run(Model, ncol, ngpts_sw, icseed_sw, p_lay, t do iCol=1,ncol call random_setseed(ipseed_sw(icol),rng_stat) call random_number(rng1D,rng_stat) - rng3D(:,:,iCol) = reshape(source = rng1D,shape=[ngpts_sw,model%levs]) + rng3D(:,:,iCol) = reshape(source = rng1D,shape=[sw_gas_props%get_ngpt(),model%levs]) enddo ! Call McICA @@ -506,21 +510,5 @@ subroutine rrtmgp_sw_cloud_optics_run(Model, ncol, ngpts_sw, icseed_sw, p_lay, t end subroutine rrtmgp_sw_cloud_optics_run subroutine rrtmgp_sw_cloud_optics_finalize() - end subroutine rrtmgp_sw_cloud_optics_finalize - - ! ######################################################################################### - ! SUBROUTINE check_error_msg - ! ######################################################################################### - subroutine check_error_msg(routine_name, error_msg) - character(len=*), intent(in) :: & - error_msg, routine_name - - if(error_msg /= "") then - print*,"ERROR("//trim(routine_name)//"): " - print*,trim(error_msg) - return - end if - end subroutine check_error_msg - - + end subroutine rrtmgp_sw_cloud_optics_finalize end module rrtmgp_sw_cloud_optics diff --git a/physics/rrtmgp_sw_gas_optics.F90 b/physics/rrtmgp_sw_gas_optics.F90 index 036ac7f0f..6c33684c6 100644 --- a/physics/rrtmgp_sw_gas_optics.F90 +++ b/physics/rrtmgp_sw_gas_optics.F90 @@ -4,12 +4,14 @@ module rrtmgp_sw_gas_optics use mo_rte_kind, only: wl 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 use netcdf - ! Parameters - integer :: ipsdsw0 - contains + + ! ######################################################################################### + ! SUBROUTINE sw_gas_optics_init + ! ######################################################################################### !! \section arg_table_rrtmgp_sw_gas_optics_init Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |--------------|----------------------------------------------|--------------------------------------------------------------------|-------|------|----------------------|-------|--------|----------| @@ -20,14 +22,11 @@ module rrtmgp_sw_gas_optics !! | mpicomm | mpi_comm | MPI communicator | index | 0 | integer | | in | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! | ipsdsw0 | initial_permutation_seed_sw | initial seed for McICA SW | none | 0 | integer | | out | F | !! | sw_gas_props | coefficients_for_sw_gas_optics | DDT containing spectral information for RRTMGP SW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | out | F | -!! | ngpts_sw | number_of_spectral_points_for_SW_calculation | Number of spectral points for SW RRTMGP calculation | none | 0 | integer | | out | F | !! - ! ######################################################################################### - ! SUBROUTINE sw_gas_optics_init - ! ######################################################################################### subroutine rrtmgp_sw_gas_optics_init(Model, Radtend, mpicomm, mpirank, mpiroot, sw_gas_props, & - ngpts_sw, errmsg, errflg) + ipsdsw0, errmsg, errflg) use netcdf #ifdef MPI use mpi @@ -47,9 +46,8 @@ subroutine rrtmgp_sw_gas_optics_init(Model, Radtend, mpicomm, mpirank, mpiroot, character(len=*), intent(out) :: & errmsg ! Error message integer, intent(out) :: & - errflg ! Error code - integer, intent(out) :: & - ngpts_sw + errflg, & ! Error code + ipsdsw0 ! type(ty_gas_optics_rrtmgp),intent(out) :: & sw_gas_props @@ -58,61 +56,62 @@ subroutine rrtmgp_sw_gas_optics_init(Model, Radtend, mpicomm, mpirank, mpiroot, type(ty_gas_concs) :: & gas_concentrations integer, dimension(:), allocatable :: & - kminor_start_lower_sw, & ! used by RRTMGP gas optics - kminor_start_upper_sw ! used by RRTMGP gas optics + kminor_start_lower_sw, & ! + kminor_start_upper_sw ! integer, dimension(:,:), allocatable :: & - band2gpt_sw, & ! used by RRTMGP gas optics - minor_limits_gpt_lower_sw, & ! used by RRTMGP gas optics - minor_limits_gpt_upper_sw ! used by RRTMGP gas optics + band2gpt_sw, & ! + minor_limits_gpt_lower_sw, & ! + minor_limits_gpt_upper_sw ! integer, dimension(:,:,:), allocatable :: & - key_species_sw ! used by RRTMGP gas optics + key_species_sw ! real(kind_phys) :: & - press_ref_trop_sw, & ! used by RRTMGP gas optics - temp_ref_p_sw, & ! used by RRTMGP gas optics - temp_ref_t_sw ! used by RRTMGP gas optics + press_ref_trop_sw, & ! + temp_ref_p_sw, & ! + temp_ref_t_sw ! real(kind_phys), dimension(:), allocatable :: & - press_ref_sw, & ! used by RRTMGP gas optics - temp_ref_sw, & ! used by RRTMGP gas optics - solar_source_sw ! used by RRTMGP gas optics + press_ref_sw, & ! + temp_ref_sw, & ! + solar_source_sw ! real(kind_phys), dimension(:,:), allocatable :: & - band_lims_sw ! used by RRTMGP gas optics + band_lims_sw ! real(kind_phys), dimension(:,:,:), allocatable :: & - vmr_ref_sw, & ! used by RRTMGP gas optics - kminor_lower_sw, & ! used by RRTMGP gas optics - kminor_upper_sw, & ! used by RRTMGP gas optics - rayl_lower_sw, & ! used by RRTMGP gas optics - rayl_upper_sw ! used by RRTMGP gas optics + vmr_ref_sw, & ! + kminor_lower_sw, & ! + kminor_upper_sw, & ! + rayl_lower_sw, & ! + rayl_upper_sw ! real(kind_phys), dimension(:,:,:,:), allocatable :: & - kmajor_sw ! used by RRTMGP gas optics + kmajor_sw ! character(len=32), dimension(:), allocatable :: & - gas_names_sw, & ! used by RRTMGP gas optics - gas_minor_sw, & ! used by RRTMGP gas optics - identifier_minor_sw, & ! used by RRTMGP gas optics - minor_gases_lower_sw, & ! used by RRTMGP gas optics - minor_gases_upper_sw, & ! used by RRTMGP gas optics - scaling_gas_lower_sw, & ! used by RRTMGP gas optics - scaling_gas_upper_sw ! used by RRTMGP gas optics + gas_names_sw, & ! + gas_minor_sw, & ! + identifier_minor_sw, & ! + minor_gases_lower_sw, & ! + minor_gases_upper_sw, & ! + scaling_gas_lower_sw, & ! + scaling_gas_upper_sw ! logical(wl), dimension(:), allocatable :: & - minor_scales_with_density_lower_sw, & ! used by RRTMGP gas optics - minor_scales_with_density_upper_sw, & ! used by RRTMGP gas optics - scale_by_complement_lower_sw, & ! used by RRTMGP gas optics - scale_by_complement_upper_sw ! used by RRTMGP gas optics + minor_scales_with_density_lower_sw, & ! + minor_scales_with_density_upper_sw, & ! + scale_by_complement_lower_sw, & ! + scale_by_complement_upper_sw ! ! Dimensions (to be broadcast across all processors) integer :: & - ntemps_sw, & ! used by RRTMGP gas optics - npress_sw, & ! used by RRTMGP gas optics - nabsorbers_sw, & ! used by RRTMGP gas optics - nextrabsorbers_sw, & ! used by RRTMGP gas optics - nminorabsorbers_sw, & ! used by RRTMGP gas optics - nmixingfracs_sw, & ! used by RRTMGP gas optics - nlayers_sw, & ! used by RRTMGP gas optics - nbnds_sw, & ! used by RRTMGP gas optics - npairs_sw, & ! used by RRTMGP gas optics - nminor_absorber_intervals_lower_sw, & ! used by RRTMGP gas optics - nminor_absorber_intervals_upper_sw, & ! used by RRTMGP gas optics - ncontributors_lower_sw, & ! used by RRTMGP gas optics - ncontributors_upper_sw ! used by RRTMGP gas optics + ntemps_sw, & ! + npress_sw, & ! + ngpts_sw, & ! + nabsorbers_sw, & ! + nextrabsorbers_sw, & ! + nminorabsorbers_sw, & ! + nmixingfracs_sw, & ! + nlayers_sw, & ! + nbnds_sw, & ! + npairs_sw, & ! + nminor_absorber_intervals_lower_sw, & ! + nminor_absorber_intervals_upper_sw, & ! + ncontributors_lower_sw, & ! + ncontributors_upper_sw ! ! Local variables integer :: status,ncid_sw,ncid_sw_clds,dimid,varID,ij,iGas @@ -411,22 +410,22 @@ subroutine rrtmgp_sw_gas_optics_init(Model, Radtend, mpicomm, mpirank, mpiroot, ipsdsw0 = sw_gas_props%get_ngpt() end subroutine rrtmgp_sw_gas_optics_init + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_gas_optics_run + ! *NOTE* The computation of the optical properties for a gaseous (+aerosols) atmosphere are + ! handled internally by the rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90:rte_sw() + ! driver. + ! If calling rte/mo_rte_sw.F90:rte_sw() directly, place calls to compute source + ! function and gas_optics() here. + ! ######################################################################################### subroutine rrtmgp_sw_gas_optics_run() - end subroutine rrtmgp_sw_gas_optics_run - subroutine rrtmgp_sw_gas_optics_finalize() - end subroutine rrtmgp_sw_gas_optics_finalize + end subroutine rrtmgp_sw_gas_optics_run + ! ######################################################################################### - ! SUBROUTINE check_error_msg + ! SUBROUTINE rrtmgp_sw_gas_optics_finalize ! ######################################################################################### - subroutine check_error_msg(routine_name, error_msg) - character(len=*), intent(in) :: & - error_msg, routine_name - - if(error_msg /= "") then - print*,"ERROR("//trim(routine_name)//"): " - print*,trim(error_msg) - return - end if - end subroutine check_error_msg + subroutine rrtmgp_sw_gas_optics_finalize() + end subroutine rrtmgp_sw_gas_optics_finalize + end module rrtmgp_sw_gas_optics diff --git a/physics/rrtmgp_sw_pre.F90 b/physics/rrtmgp_sw_pre.F90 deleted file mode 100644 index 1891cf2b9..000000000 --- a/physics/rrtmgp_sw_pre.F90 +++ /dev/null @@ -1,115 +0,0 @@ -!>\file rrtmgp_sw_pre.f90 -!! This file contains a subroutine to module_radiation_surface::setalb() to -!! setup surface albedo for SW radiation. -module rrtmgp_sw_pre - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, & - GFS_grid_type, & - GFS_radtend_type, & - GFS_sfcprop_type - use module_radiation_surface, only: NF_ALBD, setalb - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - implicit none -contains - - subroutine rrtmgp_sw_pre_init () - end subroutine rrtmgp_sw_pre_init - -!> \section arg_table_rrtmgp_sw_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |-----------------------|-------------------------------------------------------------|--------------------------------------------------------------------|----------|------|----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | in | F | -!! | Grid | GFS_grid_type_instance | Fortran DDT containing FV3-GFS grid and interpolation related data | DDT | 0 | GFS_grid_type | | in | F | -!! | Sfcprop | GFS_sfcprop_type_instance | Fortran DDT containing FV3-GFS surface fields | DDT | 0 | GFS_sfcprop_type | | in | F | -!! | Radtend | GFS_radtend_type_instance | Fortran DDT containing FV3-GFS radiation tendencies | DDT | 0 | GFS_radtend_type | | inout | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | nday | daytime_points_dimension | daytime points dimension | count | 0 | integer | | out | F | -!! | idxday | daytime_points | daytime points | index | 1 | integer | | out | F | -!! | tsfg | surface_ground_temperature_for_radiation | surface ground temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | tsfa | surface_air_temperature_for_radiation | lowest model layer air temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | sw_gas_props | coefficients_for_sw_gas_optics | DDT containing spectral information for RRTMGP SW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | in | F | -!! | sfc_alb_nir_dir | surface_shortwave_albedo_near_infrared_direct_in_each_band | surface sw near-infrared direct albedo in each SW band | frac | 2 | real | kind_phys | out | F | -!! | sfc_alb_nir_dif | surface_shortwave_albedo_near_infrared_diffuse_in_each_band | surface sw near-infrared diffuse albedo in each SW band | frac | 2 | real | kind_phys | out | F | -!! | sfc_alb_uvvis_dir | surface_shortwave_albedo_uv_visible_direct_in_each_band | surface sw uv-visible direct albedo in each SW band | frac | 2 | real | kind_phys | out | F | -!! | sfc_alb_uvvis_dif | surface_shortwave_albedo_uv_visible_diffuse_in_each_band | surface sw uv-visible diffuse albedo in each SW band | frac | 2 | real | kind_phys | out | F | -!! | alb1d | surface_albedo_perturbation | surface albedo perturbation | frac | 1 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine rrtmgp_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, sw_gas_props, & - nday, idxday, tsfg, tsfa, sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, & - sfc_alb_uvvis_dif, alb1d, errmsg, errflg) - - ! Inputs - type(ty_gas_optics_rrtmgp),intent(in) :: & - sw_gas_props ! RRTMGP DDT containing spectral information for SW calculation - type(GFS_control_type), intent(in) :: Model - type(GFS_radtend_type), intent(inout) :: Radtend - type(GFS_sfcprop_type), intent(in) :: Sfcprop - type(GFS_grid_type), intent(in) :: Grid - integer, intent(in) :: im - integer, intent(out) :: nday - integer, dimension(size(Grid%xlon,1)), intent(out) :: idxday - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: alb1d - - ! Outputs - real(kind_phys),dimension(sw_gas_props%get_nband(),IM),intent(out) :: & - sfc_alb_nir_dir, & ! Shortwave surface albedo (nIR-direct) - sfc_alb_nir_dif, & ! Shortwave surface albedo (nIR-diffuse) - sfc_alb_uvvis_dir, & ! Shortwave surface albedo (uvvis-direct) - sfc_alb_uvvis_dif ! Shortwave surface albedo (uvvis-diffuse) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, iBand - real(kind=kind_phys), dimension(size(Grid%xlon,1),NF_ALBD) :: sfcalb - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (Model%lsswr) then - ! Check for daytime points for SW radiation. - nday = 0 - idxday = 0 - do i = 1, IM - if (Radtend%coszen(i) >= 0.0001) then - nday = nday + 1 - idxday(nday) = i - endif - enddo - - ! Call module_radiation_surface::setalb() to setup surface albedo. - call setalb (Sfcprop%slmsk, Sfcprop%snowd, Sfcprop%sncovr,& ! --- inputs: - Sfcprop%snoalb, Sfcprop%zorl, Radtend%coszen,& - tsfg, tsfa, Sfcprop%hprim, Sfcprop%alvsf, & - Sfcprop%alnsf, Sfcprop%alvwf, Sfcprop%alnwf, & - Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, & - Sfcprop%tisfc, IM, & - alb1d, Model%pertalb, & ! mg, sfc-perts - sfcalb) ! --- outputs - - ! Approximate mean surface albedo from vis- and nir- diffuse values. - Radtend%sfalb(:) = max(0.01, 0.5 * (sfcalb(:,2) + sfcalb(:,4))) - else - nday = 0 - idxday = 0 - sfcalb = 0.0 - endif - - ! Spread across all SW bands - do iBand=1,sw_gas_props%get_nband() - sfc_alb_nir_dir(iBand,1:IM) = sfcalb(1:IM,1) - sfc_alb_nir_dif(iBand,1:IM) = sfcalb(1:IM,2) - sfc_alb_uvvis_dir(iBand,1:IM) = sfcalb(1:IM,3) - sfc_alb_uvvis_dif(iBand,1:IM) = sfcalb(1:IM,4) - enddo - - end subroutine rrtmgp_sw_pre_run - - subroutine rrtmgp_sw_pre_finalize () - end subroutine rrtmgp_sw_pre_finalize - -end module rrtmgp_sw_pre