From a60e1e1fa4388e222dbc9771a20d315290ce7493 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 21 May 2019 16:23:01 -0600 Subject: [PATCH] RRTMGP DDTs working! --- physics/GFS_rrtmgp_post.F90 | 518 ++++++++++++++++--------- physics/GFS_rrtmgp_pre.F90 | 55 +-- physics/rrtmgp_lw.F90 | 729 +++++++++++++++++++++++++++++++++-- physics/rrtmgp_lw_post.F90 | 174 --------- physics/rrtmgp_lw_pre.F90 | 746 ------------------------------------ physics/rrtmgp_sw.F90 | 98 +++-- 6 files changed, 1119 insertions(+), 1201 deletions(-) delete mode 100644 physics/rrtmgp_lw_post.F90 delete mode 100644 physics/rrtmgp_lw_pre.F90 diff --git a/physics/GFS_rrtmgp_post.F90 b/physics/GFS_rrtmgp_post.F90 index 3f8d0c1d8..1d5002b93 100644 --- a/physics/GFS_rrtmgp_post.F90 +++ b/physics/GFS_rrtmgp_post.F90 @@ -1,210 +1,370 @@ !>\file GFS_rrtmgp_post.f90 !! This file contains - module GFS_rrtmgp_post - contains +module GFS_rrtmgp_post + use machine, only: kind_phys + use GFS_typedefs, only: GFS_statein_type, & + GFS_coupling_type, & + GFS_control_type, & + GFS_grid_type, & + GFS_radtend_type, & + GFS_diag_type + use module_radiation_aerosols, only: NSPC1 + use module_radsw_parameters, only: cmpfsw_type + use module_radlw_parameters, only: topflw_type, sfcflw_type, proflw_type + use module_radsw_parameters, only: topfsw_type, sfcfsw_type, profsw_type + ! RRTMGP DDT's + 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, only: check_error_msg + + implicit none +contains !>\defgroup GFS_rrtmgp_post GFS RRTMGP Scheme Post !! @{ !> \section arg_table_GFS_rrtmgp_post_init Argument Table !! - subroutine GFS_rrtmgp_post_init () - end subroutine GFS_rrtmgp_post_init + subroutine GFS_rrtmgp_post_init () + end subroutine GFS_rrtmgp_post_init !> \section arg_table_GFS_rrtmgp_post_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 | -!! | Diag | GFS_diag_type_instance | Fortran DDT containing FV3-GFS diagnotics data | DDT | 0 | GFS_diag_type | | inout | F | -!! | Radtend | GFS_radtend_type_instance | Fortran DDT containing FV3-GFS radiation tendencies | DDT | 0 | GFS_radtend_type | | in | F | -!! | Statein | GFS_statein_type_instance | Fortran DDT containing FV3-GFS prognostic state data in from dycore | DDT | 0 | GFS_statein_type | | in | F | -!! | Coupling | GFS_coupling_type_instance | Fortran DDT containing FV3-GFS fields to/from coupling with other components | DDT | 0 | GFS_coupling_type | | inout | F | -!! | scmpsw | components_of_surface_downward_shortwave_fluxes | derived type for special components of surface downward shortwave fluxes | W m-2 | 1 | cmpfsw_type | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | lm | vertical_layer_dimension_for_radiation | number of vertical layers for radiation calculation | count | 0 | integer | | in | F | -!! | ltp | extra_top_layer | extra top layers | none | 0 | integer | | in | F | -!! | kt | vertical_index_difference_between_layer_and_upper_bound | vertical index difference between layer and upper bound | index | 0 | integer | | in | F | -!! | kb | vertical_index_difference_between_layer_and_lower_bound | vertical index difference between layer and lower bound | index | 0 | integer | | in | F | -!! | kd | vertical_index_difference_between_inout_and_local | vertical index difference between in/out and local | index | 0 | integer | | in | F | -!! | raddt | time_step_for_radiation | radiation time step | s | 0 | real | kind_phys | in | F | -!! | aerodp | atmosphere_optical_thickness_due_to_ambient_aerosol_particles | vertical integrated optical depth for various aerosol species | none | 2 | real | kind_phys | in | F | -!! | cldsa | cloud_area_fraction_for_radiation | fraction of clouds for low, middle, high, total and BL | frac | 2 | real | kind_phys | in | F | -!! | mtopa | model_layer_number_at_cloud_top | vertical indices for low, middle and high cloud tops | index | 2 | integer | | in | F | -!! | mbota | model_layer_number_at_cloud_base | vertical indices for low, middle and high cloud bases | index | 2 | integer | | in | F | -!! | clouds1 | total_cloud_fraction | layer total cloud fraction | frac | 2 | real | kind_phys | in | F | -!! | cldtaulw | cloud_optical_depth_layers_at_10mu_band | approx 10mu band layer cloud optical depth | none | 2 | real | kind_phys | in | F | -!! | cldtausw | cloud_optical_depth_layers_at_0.55mu_band | approx .55mu band layer cloud optical depth | none | 2 | 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 | +!! | 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 | +!! | Diag | GFS_diag_type_instance | Fortran DDT containing FV3-GFS diagnotics data | DDT | 0 | GFS_diag_type | | inout | F | +!! | Radtend | GFS_radtend_type_instance | Fortran DDT containing FV3-GFS radiation tendencies | DDT | 0 | GFS_radtend_type | | inout | F | +!! | Statein | GFS_statein_type_instance | Fortran DDT containing FV3-GFS prognostic state data in from dycore | DDT | 0 | GFS_statein_type | | in | F | +!! | Coupling | GFS_coupling_type_instance | Fortran DDT containing FV3-GFS fields to/from coupling with other components | DDT | 0 | GFS_coupling_type | | inout | F | +!! | scmpsw | components_of_surface_downward_shortwave_fluxes | derived type for special components of surface downward shortwave fluxes | W m-2 | 1 | cmpfsw_type | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | lm | vertical_layer_dimension_for_radiation | number of vertical layers for radiation calculation | count | 0 | integer | | in | F | +!! | ltp | extra_top_layer | extra top layers | none | 0 | integer | | in | F | +!! | kt | vertical_index_difference_between_layer_and_upper_bound | vertical index difference between layer and upper bound | index | 0 | integer | | in | F | +!! | kb | vertical_index_difference_between_layer_and_lower_bound | vertical index difference between layer and lower bound | index | 0 | integer | | in | F | +!! | kd | vertical_index_difference_between_inout_and_local | vertical index difference between in/out and local | index | 0 | integer | | in | F | +!! | raddt | time_step_for_radiation | radiation time step | s | 0 | real | kind_phys | in | F | +!! | aerodp | atmosphere_optical_thickness_due_to_ambient_aerosol_particles | vertical integrated optical depth for various aerosol species | none | 2 | real | kind_phys | in | F | +!! | cldsa | cloud_area_fraction_for_radiation | fraction of clouds for low, middle, high, total and BL | frac | 2 | real | kind_phys | in | F | +!! | mtopa | model_layer_number_at_cloud_top | vertical indices for low, middle and high cloud tops | index | 2 | integer | | in | F | +!! | mbota | model_layer_number_at_cloud_base | vertical indices for low, middle and high cloud bases | index | 2 | integer | | in | F | +!! | cloud_fraction | total_cloud_fraction | layer total cloud fraction | frac | 2 | real | kind_phys | in | F | +!! | cldtaulw | cloud_optical_depth_layers_at_10mu_band | approx 10mu band layer cloud optical depth | none | 2 | real | kind_phys | in | F | +!! | cldtausw | cloud_optical_depth_layers_at_0.55mu_band | approx .55mu band layer cloud optical depth | none | 2 | 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 | +!! | p_lev | air_pressure_at_interface_for_radiation_in_hPa | air pressure level | hPa | 2 | real | kind_phys | in | F | +!! | fluxLW_allsky | lw_flux_profiles_byband_allsky | Fortran DDT containing RRTMGP 3D fluxes | DDT | 0 | ty_fluxes_byband | | in | F | +!! | fluxLW_clrsky | lw_flux_profiles_byband_clrsky | Fortran DDT containing RRTMGP 3D fluxes | DDT | 0 | ty_fluxes_byband | | in | F | +!! | kdist_lw | K_distribution_file_for_RRTMGP_LW_scheme | 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_fluxes_top_atmosphere | longwave total sky fluxes at the top of the atm | W m-2 | 1 | topflw_type | | inout | F | +!! | sfcflx | lw_fluxes_sfc | longwave total sky fluxes at the Earth surface | W m-2 | 1 | sfcflw_type | | inout | F | +!! | hlw0 | tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_time_step | longwave clear sky heating rate | K s-1 | 2 | real | kind_phys | inout | T | +!! | flxprf | lw_fluxes | lw fluxes total sky / csk and up / down at levels | W m-2 | 2 | proflw_type | | inout | T | +!! | 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_post_run (Model, Grid, Diag, Radtend, Statein, & + subroutine GFS_rrtmgp_post_run (Model, Grid, Diag, Radtend, Statein, & Coupling, scmpsw, im, lm, ltp, kt, kb, kd, raddt, aerodp, & - cldsa, mtopa, mbota, clouds1, cldtaulw, cldtausw, & - errmsg, errflg) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_statein_type, & - GFS_coupling_type, & - GFS_control_type, & - GFS_grid_type, & - GFS_radtend_type, & - GFS_diag_type - use module_radiation_aerosols, only: NSPC1 - use module_radsw_parameters, only: cmpfsw_type - use module_radlw_parameters, only: topflw_type, sfcflw_type - use module_radsw_parameters, only: topfsw_type, sfcfsw_type - - implicit none - - ! Interface variables - type(GFS_control_type), intent(in) :: Model - type(GFS_grid_type), intent(in) :: Grid - type(GFS_statein_type), intent(in) :: Statein - type(GFS_coupling_type), intent(inout) :: Coupling - type(GFS_radtend_type), intent(in) :: Radtend - type(GFS_diag_type), intent(inout) :: Diag - type(cmpfsw_type), dimension(size(Grid%xlon,1)), intent(in) :: scmpsw - - integer, intent(in) :: im, lm, ltp, kt, kb, kd - real(kind=kind_phys), intent(in) :: raddt - - real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(in) :: aerodp - real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(in) :: cldsa - integer, dimension(size(Grid%xlon,1),3), intent(in) :: mbota, mtopa - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: clouds1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: cldtausw - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: cldtaulw - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, j, k, k1, itop, ibtc - real(kind=kind_phys) :: tem0d, tem1, tem2 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. (Model%lsswr .or. Model%lslwr)) return + cldsa, mtopa, mbota, cloud_fraction, cldtaulw, cldtausw, p_lev, kdist_lw, & + tsfa, fluxLW_allsky, fluxLW_clrsky, hlwc, topflx, sfcflx, hlw0, flxprf,errmsg, errflg) -!> - For time averaged output quantities (including total-sky and -!! clear-sky SW and LW fluxes at TOA and surface; conventional -!! 3-domain cloud amount, cloud top and base pressure, and cloud top -!! temperature; aerosols AOD, etc.), store computed results in -!! corresponding slots of array fluxr with appropriate time weights. + ! Inputs + type(GFS_control_type), intent(in) :: & + Model ! Fortran DDT containing FV3-GFS model control parameters + type(GFS_grid_type), intent(in) :: & + Grid ! Fortran DDT containing FV3-GFS grid and interpolation related data + type(GFS_statein_type), intent(in) :: & + Statein ! Fortran DDT containing FV3-GFS prognostic state data in from dycore + type(GFS_coupling_type), intent(inout) :: & + Coupling ! Fortran DDT containing FV3-GFS fields to/from coupling with other components + type(GFS_radtend_type), intent(inout) :: & + Radtend ! Fortran DDT containing FV3-GFS radiation tendencies + type(GFS_diag_type), intent(inout) :: & + Diag ! Fortran DDT containing FV3-GFS diagnotics data + type(cmpfsw_type), dimension(size(Grid%xlon,1)), intent(in) :: & + scmpsw ! derived type for special components of surface downward shortwave fluxes + integer, intent(in) :: & + im, & ! Horizontal loop extent + lm, & ! Number of vertical layers for radiation calculation + ltp, & ! Extra-top-layers + kt, & ! Vertical index difference between layer and upper bound + kb, & ! Vertical index difference between layer and upper bound + kd ! Vertical index difference between in/out and local + real(kind_phys), intent(in) :: & + raddt ! Radiation time step + real(kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: & + tsfa ! Lowest model layer air temperature for radiation + real(kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(in) :: & + aerodp ! Vertical integrated optical depth for various aerosol species + real(kind_phys), dimension(size(Grid%xlon,1),5), intent(in) :: & + cldsa ! Fraction of clouds for low, middle, high, total and BL + integer, dimension(size(Grid%xlon,1),3), intent(in) ::& + mbota, & ! vertical indices for low, middle and high cloud tops + mtopa ! vertical indices for low, middle and high cloud bases + real(kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: & + cloud_fraction, & ! Total cloud fraction in each layer + cldtausw, & ! approx .55mu band layer cloud optical depth + cldtaulw ! approx 10mu band layer cloud optical depth + type(ty_gas_optics_rrtmgp),intent(in) :: & + kdist_lw ! DDT containing LW spectral information + real(kind_phys), dimension(size(Grid%xlon,1), Model%levr+LTP+1), intent(in) :: & + p_lev ! Pressure @ model layer-interfaces (hPa) + type(ty_fluxes_byband),intent(in) :: & + fluxLW_allsky, & ! All-sky flux (W/m2) + fluxLW_clrsky ! Clear-sky flux (W/m2) + + ! Outputs + character(len=*), intent(out) :: & + errmsg + integer, intent(out) :: & + errflg + real(kind_phys),dimension(size(Grid%xlon,1), Model%levr+LTP),intent(out) :: & + hlwc ! All-sky heating-rate (K/sec) + type(topflw_type), dimension(size(Grid%xlon,1)), intent(inout) :: & + topflx ! radiation fluxes at top, components: + ! upfxc - total sky upward flux at top (w/m2) + ! upfx0 - clear sky upward flux at top (w/m2) + type(sfcflw_type), dimension(size(Grid%xlon,1)), intent(inout) :: & + sfcflx ! radiation fluxes at sfc, components: + ! upfxc - total sky upward flux at sfc (w/m2) + ! upfx0 - clear sky upward flux at sfc (w/m2) + ! dnfxc - total sky downward flux at sfc (w/m2) + ! dnfx0 - clear sky downward flux at sfc (w/m2) + + ! Outputs (optional) + real(kind_phys), dimension(size(Grid%xlon,1), Model%levr+LTP), optional, intent(inout) :: & + hlw0 ! Clear-sky heating rate (K/sec) + type(proflw_type), dimension(size(Grid%xlon,1), Model%levr+LTP+1), optional, intent(inout) :: & + flxprf ! 2D radiative fluxes, components: + ! upfxc - total sky upward flux (W/m2) + ! dnfxc - total sky dnward flux (W/m2) + ! upfx0 - clear sky upward flux (W/m2) + ! dnfx0 - clear sky dnward flux (W/m2) -! --- ... collect the fluxr data for wrtsfc + ! Local variables + integer :: i, j, k, k1, itop, ibtc, iBand, iSFC, iTOA + real(kind_phys) :: tem0d, tem1, tem2 + real(kind_phys), dimension(size(Grid%xlon,1), Model%levr+LTP) :: thetaTendClrSky, thetaTendAllSky + logical :: l_ClrSky_HR, l_fluxes2D, top_at_1 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. (Model%lsswr .or. Model%lslwr)) return + + ! Are any optional outputs requested? + l_ClrSky_HR = present(hlw0) + l_fluxes2D = present(flxprf) - if (Model%lssav) then - if (Model%lsswr) then + ! What is vertical ordering? + top_at_1 = (p_lev(1,1) .lt. p_lev(1, Model%levr+LTP)) + if (top_at_1) then + iSFC = Model%levr+LTP+1 + iTOA = 1 + else + iSFC = 1 + iTOA = Model%levr+LTP+1 + endif + + ! ####################################################################################### + ! Compute LW heating-rates. (Note. This piece was originally in rrtmg_lw.F90:_run()) + ! ####################################################################################### + if (Model%lslwr) then + ! Clear-sky heating-rate (optional) + if (l_ClrSky_HR) then + call check_error_msg(compute_heating_rate( & + fluxLW_clrsky%flux_up, & + fluxLW_clrsky%flux_dn, & + p_lev, & + thetaTendClrSky)) + endif + ! All-sky heating-rate (mandatory) + call check_error_msg(compute_heating_rate( & + fluxLW_allsky%flux_up, & + fluxLW_allsky%flux_dn, & + p_lev, & + thetaTendAllSky)) + + ! Copy fluxes from RRTGMP types into model radiation types. + ! Mandatory outputs + topflx%upfxc = fluxLW_allsky%flux_up(:,iTOA) + topflx%upfx0 = fluxLW_clrsky%flux_up(:,iTOA) + sfcflx%upfxc = fluxLW_allsky%flux_up(:,iSFC) + sfcflx%upfx0 = fluxLW_clrsky%flux_up(:,iSFC) + sfcflx%dnfxc = fluxLW_allsky%flux_dn(:,iSFC) + sfcflx%dnfx0 = fluxLW_clrsky%flux_dn(:,iSFC) + hlwc = thetaTendAllSky + + ! Optional outputs + if(l_fluxes2D) then + flxprf%upfxc = fluxLW_allsky%flux_up + flxprf%dnfxc = fluxLW_allsky%flux_dn + flxprf%upfx0 = fluxLW_clrsky%flux_up + flxprf%dnfx0 = fluxLW_clrsky%flux_dn + endif + if (l_ClrSky_HR) then + hlw0 = thetaTendClrSky + endif + endif + + ! ####################################################################################### + ! Save LW heating-rates (Note. This piece was originally in rrtmg_lw_post.F90:_run()) + ! ####################################################################################### + if (Model%lslwr) then + !> -# Save calculation results + !> - Save surface air temp for diurnal adjustment at model t-steps + + Radtend%tsflw (:) = tsfa(:) + + do k = 1, LM + k1 = k + kd + Radtend%htrlw(1:im,k) = hlwc(1:im,k1) + enddo + ! --- repopulate the points above levr + if (lm < Model%levs) then + do k = lm,Model%levs + Radtend%htrlw (1:im,k) = Radtend%htrlw (1:im,LM) + enddo + endif + + if (Model%lwhtr) then + do k = 1, lm + k1 = k + kd + Radtend%lwhc(1:im,k) = hlw0(1:im,k1) + enddo + ! --- repopulate the points above levr + if (lm < Model%levs) then + do k = lm,Model%levs + Radtend%lwhc(1:im,k) = Radtend%lwhc(1:im,LM) + enddo + endif + endif + + ! --- radiation fluxes for other physics processes + Coupling%sfcdlw(:) = Radtend%sfcflw(:)%dnfxc + + endif ! end_if_lslwr + + !> - For time averaged output quantities (including total-sky and + !! clear-sky SW and LW fluxes at TOA and surface; conventional + !! 3-domain cloud amount, cloud top and base pressure, and cloud top + !! temperature; aerosols AOD, etc.), store computed results in + !! corresponding slots of array fluxr with appropriate time weights. + + ! --- ... collect the fluxr data for wrtsfc + + if (Model%lssav) then + if (Model%lsswr) then do i=1,im - Diag%fluxr(i,34) = Diag%fluxr(i,34) + Model%fhswr*aerodp(i,1) ! total aod at 550nm - Diag%fluxr(i,35) = Diag%fluxr(i,35) + Model%fhswr*aerodp(i,2) ! DU aod at 550nm - Diag%fluxr(i,36) = Diag%fluxr(i,36) + Model%fhswr*aerodp(i,3) ! BC aod at 550nm - Diag%fluxr(i,37) = Diag%fluxr(i,37) + Model%fhswr*aerodp(i,4) ! OC aod at 550nm - Diag%fluxr(i,38) = Diag%fluxr(i,38) + Model%fhswr*aerodp(i,5) ! SU aod at 550nm - Diag%fluxr(i,39) = Diag%fluxr(i,39) + Model%fhswr*aerodp(i,6) ! SS aod at 550nm + Diag%fluxr(i,34) = Diag%fluxr(i,34) + Model%fhswr*aerodp(i,1) ! total aod at 550nm + Diag%fluxr(i,35) = Diag%fluxr(i,35) + Model%fhswr*aerodp(i,2) ! DU aod at 550nm + Diag%fluxr(i,36) = Diag%fluxr(i,36) + Model%fhswr*aerodp(i,3) ! BC aod at 550nm + Diag%fluxr(i,37) = Diag%fluxr(i,37) + Model%fhswr*aerodp(i,4) ! OC aod at 550nm + Diag%fluxr(i,38) = Diag%fluxr(i,38) + Model%fhswr*aerodp(i,5) ! SU aod at 550nm + Diag%fluxr(i,39) = Diag%fluxr(i,39) + Model%fhswr*aerodp(i,6) ! SS aod at 550nm enddo - endif - -! --- save lw toa and sfc fluxes - if (Model%lslwr) then + endif + + ! --- save lw toa and sfc fluxes + if (Model%lslwr) then do i=1,im -! --- lw total-sky fluxes - Diag%fluxr(i,1 ) = Diag%fluxr(i,1 ) + Model%fhlwr * Diag%topflw(i)%upfxc ! total sky top lw up - Diag%fluxr(i,19) = Diag%fluxr(i,19) + Model%fhlwr * Radtend%sfcflw(i)%dnfxc ! total sky sfc lw dn - Diag%fluxr(i,20) = Diag%fluxr(i,20) + Model%fhlwr * Radtend%sfcflw(i)%upfxc ! total sky sfc lw up -! --- lw clear-sky fluxes - Diag%fluxr(i,28) = Diag%fluxr(i,28) + Model%fhlwr * Diag%topflw(i)%upfx0 ! clear sky top lw up - Diag%fluxr(i,30) = Diag%fluxr(i,30) + Model%fhlwr * Radtend%sfcflw(i)%dnfx0 ! clear sky sfc lw dn - Diag%fluxr(i,33) = Diag%fluxr(i,33) + Model%fhlwr * Radtend%sfcflw(i)%upfx0 ! clear sky sfc lw up + ! --- lw total-sky fluxes + Diag%fluxr(i,1 ) = Diag%fluxr(i,1 ) + Model%fhlwr * Diag%topflw(i)%upfxc ! total sky top lw up + Diag%fluxr(i,19) = Diag%fluxr(i,19) + Model%fhlwr * Radtend%sfcflw(i)%dnfxc ! total sky sfc lw dn + Diag%fluxr(i,20) = Diag%fluxr(i,20) + Model%fhlwr * Radtend%sfcflw(i)%upfxc ! total sky sfc lw up + ! --- lw clear-sky fluxes + Diag%fluxr(i,28) = Diag%fluxr(i,28) + Model%fhlwr * Diag%topflw(i)%upfx0 ! clear sky top lw up + Diag%fluxr(i,30) = Diag%fluxr(i,30) + Model%fhlwr * Radtend%sfcflw(i)%dnfx0 ! clear sky sfc lw dn + Diag%fluxr(i,33) = Diag%fluxr(i,33) + Model%fhlwr * Radtend%sfcflw(i)%upfx0 ! clear sky sfc lw up enddo - endif - -! --- save sw toa and sfc fluxes with proper diurnal sw wgt. coszen=mean cosz over daylight -! part of sw calling interval, while coszdg= mean cosz over entire interval - if (Model%lsswr) then + endif + + ! --- save sw toa and sfc fluxes with proper diurnal sw wgt. coszen=mean cosz over daylight + ! part of sw calling interval, while coszdg= mean cosz over entire interval + if (Model%lsswr) then do i = 1, IM - if (Radtend%coszen(i) > 0.) then -! --- sw total-sky fluxes -! ------------------- - tem0d = Model%fhswr * Radtend%coszdg(i) / Radtend%coszen(i) - Diag%fluxr(i,2 ) = Diag%fluxr(i,2) + Diag%topfsw(i)%upfxc * tem0d ! total sky top sw up - Diag%fluxr(i,3 ) = Diag%fluxr(i,3) + Radtend%sfcfsw(i)%upfxc * tem0d ! total sky sfc sw up - Diag%fluxr(i,4 ) = Diag%fluxr(i,4) + Radtend%sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn -! --- sw uv-b fluxes -! -------------- - Diag%fluxr(i,21) = Diag%fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn - Diag%fluxr(i,22) = Diag%fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn -! --- sw toa incoming fluxes -! ---------------------- - Diag%fluxr(i,23) = Diag%fluxr(i,23) + Diag%topfsw(i)%dnfxc * tem0d ! top sw dn -! --- sw sfc flux components -! ---------------------- - Diag%fluxr(i,24) = Diag%fluxr(i,24) + scmpsw(i)%visbm * tem0d ! uv/vis beam sw dn - Diag%fluxr(i,25) = Diag%fluxr(i,25) + scmpsw(i)%visdf * tem0d ! uv/vis diff sw dn - Diag%fluxr(i,26) = Diag%fluxr(i,26) + scmpsw(i)%nirbm * tem0d ! nir beam sw dn - Diag%fluxr(i,27) = Diag%fluxr(i,27) + scmpsw(i)%nirdf * tem0d ! nir diff sw dn -! --- sw clear-sky fluxes -! ------------------- - Diag%fluxr(i,29) = Diag%fluxr(i,29) + Diag%topfsw(i)%upfx0 * tem0d ! clear sky top sw up - Diag%fluxr(i,31) = Diag%fluxr(i,31) + Radtend%sfcfsw(i)%upfx0 * tem0d ! clear sky sfc sw up - Diag%fluxr(i,32) = Diag%fluxr(i,32) + Radtend%sfcfsw(i)%dnfx0 * tem0d ! clear sky sfc sw dn - endif + if (Radtend%coszen(i) > 0.) then + ! --- sw total-sky fluxes + ! ------------------- + tem0d = Model%fhswr * Radtend%coszdg(i) / Radtend%coszen(i) + Diag%fluxr(i,2 ) = Diag%fluxr(i,2) + Diag%topfsw(i)%upfxc * tem0d ! total sky top sw up + Diag%fluxr(i,3 ) = Diag%fluxr(i,3) + Radtend%sfcfsw(i)%upfxc * tem0d ! total sky sfc sw up + Diag%fluxr(i,4 ) = Diag%fluxr(i,4) + Radtend%sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn + ! --- sw uv-b fluxes + ! -------------- + Diag%fluxr(i,21) = Diag%fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn + Diag%fluxr(i,22) = Diag%fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn + ! --- sw toa incoming fluxes + ! ---------------------- + Diag%fluxr(i,23) = Diag%fluxr(i,23) + Diag%topfsw(i)%dnfxc * tem0d ! top sw dn + ! --- sw sfc flux components + ! ---------------------- + Diag%fluxr(i,24) = Diag%fluxr(i,24) + scmpsw(i)%visbm * tem0d ! uv/vis beam sw dn + Diag%fluxr(i,25) = Diag%fluxr(i,25) + scmpsw(i)%visdf * tem0d ! uv/vis diff sw dn + Diag%fluxr(i,26) = Diag%fluxr(i,26) + scmpsw(i)%nirbm * tem0d ! nir beam sw dn + Diag%fluxr(i,27) = Diag%fluxr(i,27) + scmpsw(i)%nirdf * tem0d ! nir diff sw dn + ! --- sw clear-sky fluxes + ! ------------------- + Diag%fluxr(i,29) = Diag%fluxr(i,29) + Diag%topfsw(i)%upfx0 * tem0d ! clear sky top sw up + Diag%fluxr(i,31) = Diag%fluxr(i,31) + Radtend%sfcfsw(i)%upfx0 * tem0d ! clear sky sfc sw up + Diag%fluxr(i,32) = Diag%fluxr(i,32) + Radtend%sfcfsw(i)%dnfx0 * tem0d ! clear sky sfc sw dn + endif enddo - endif - -! --- save total and boundary layer clouds - - if (Model%lsswr .or. Model%lslwr) then + endif + + ! --- save total and boundary layer clouds + + if (Model%lsswr .or. Model%lslwr) then do i=1,im - Diag%fluxr(i,17) = Diag%fluxr(i,17) + raddt * cldsa(i,4) - Diag%fluxr(i,18) = Diag%fluxr(i,18) + raddt * cldsa(i,5) + Diag%fluxr(i,17) = Diag%fluxr(i,17) + raddt * cldsa(i,4) + Diag%fluxr(i,18) = Diag%fluxr(i,18) + raddt * cldsa(i,5) enddo - -! --- save cld frac,toplyr,botlyr and top temp, note that the order -! of h,m,l cloud is reversed for the fluxr output. -! --- save interface pressure (pa) of top/bot - + + ! --- save cld frac,toplyr,botlyr and top temp, note that the order + ! of h,m,l cloud is reversed for the fluxr output. + ! --- save interface pressure (pa) of top/bot + do j = 1, 3 - do i = 1, IM - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - kd - ibtc = mbota(i,j) - kd - Diag%fluxr(i, 8-j) = Diag%fluxr(i, 8-j) + tem0d - Diag%fluxr(i,11-j) = Diag%fluxr(i,11-j) + tem0d * Statein%prsi(i,itop+kt) - Diag%fluxr(i,14-j) = Diag%fluxr(i,14-j) + tem0d * Statein%prsi(i,ibtc+kb) - Diag%fluxr(i,17-j) = Diag%fluxr(i,17-j) + tem0d * Statein%tgrs(i,itop) - -! Anning adds optical depth and emissivity output - tem1 = 0. - tem2 = 0. - do k=ibtc,itop - tem1 = tem1 + cldtausw(i,k) ! approx .55 mu channel - tem2 = tem2 + cldtaulw(i,k) ! approx 10. mu channel - enddo - Diag%fluxr(i,43-j) = Diag%fluxr(i,43-j) + tem0d * tem1 - Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) - enddo + do i = 1, IM + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) - kd + ibtc = mbota(i,j) - kd + Diag%fluxr(i, 8-j) = Diag%fluxr(i, 8-j) + tem0d + Diag%fluxr(i,11-j) = Diag%fluxr(i,11-j) + tem0d * Statein%prsi(i,itop+kt) + Diag%fluxr(i,14-j) = Diag%fluxr(i,14-j) + tem0d * Statein%prsi(i,ibtc+kb) + Diag%fluxr(i,17-j) = Diag%fluxr(i,17-j) + tem0d * Statein%tgrs(i,itop) + + ! Anning adds optical depth and emissivity output + tem1 = 0. + tem2 = 0. + do k=ibtc,itop + tem1 = tem1 + cldtausw(i,k) ! approx .55 mu channel + tem2 = tem2 + cldtaulw(i,k) ! approx 10. mu channel + enddo + Diag%fluxr(i,43-j) = Diag%fluxr(i,43-j) + tem0d * tem1 + Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) + enddo enddo - endif - -! if (.not. Model%uni_cld) then - if (Model%lgocart .or. Model%ldiag3d) then + endif + + ! if (.not. Model%uni_cld) then + if (Model%lgocart .or. Model%ldiag3d) then do k = 1, LM - k1 = k + kd - Coupling%cldcovi(1:im,k) = clouds1(1:im,k1) + k1 = k + kd + Coupling%cldcovi(1:im,k) = cloud_fraction(1:im,k1) enddo - endif - endif ! end_if_lssav -! - end subroutine GFS_rrtmgp_post_run + endif + endif ! end_if_lssav + ! + end subroutine GFS_rrtmgp_post_run !> \section arg_table_GFS_rrtmgp_post_finalize Argument Table !! - subroutine GFS_rrtmgp_post_finalize () - end subroutine GFS_rrtmgp_post_finalize + subroutine GFS_rrtmgp_post_finalize () + end subroutine GFS_rrtmgp_post_finalize !! @} - end module GFS_rrtmgp_post +end module GFS_rrtmgp_post diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 428d72337..07cc4d9de 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -91,7 +91,8 @@ end subroutine GFS_rrtmgp_pre_init !! | kdist_cldy_sw | K_distribution_file_for_cloudy_RRTMGP_SW_scheme | DDT containing spectral information for cloudy RRTMGP SW radiation scheme | DDT | 0 | ty_cloud_optics | | in | F | !! | optical_props_clouds | optical_properties_for_cloudy_atmosphere | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_1scl | | out | F | !! | optical_props_aerosol | optical_properties_for_aerosols | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_1scl | | out | F | -!! | gas_concentrations | Gas_concentrations_for_RRTMGP_suite | DDT containing gas concentrations for RRTMGP radiation scheme | DDT | 0 | ty_gas_concs | | inout | F | +!! | gas_concentrations | Gas_concentrations_for_RRTMGP_suite | DDT containing gas concentrations for RRTMGP radiation scheme | DDT | 0 | ty_gas_concs | | out | F | +!! | sfc_emiss_byband | surface_longwave_emissivity_in_each_band | surface lw emissivity in fraction in each LW band | frac | 2 | real | kind_phys | out | F | !! ! Attention - the output arguments lm, im, lmk, lmp must not be set ! in the CCPP version - they are defined in the interstitial_create routine @@ -104,7 +105,7 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, gasvmr_cfc113, faersw1, faersw2, faersw3, & ! OUT faerlw1, faerlw2, faerlw3, aerodp, clouds1, clouds2, clouds3, clouds4, clouds5, & ! OUT clouds6, clouds7, clouds8, clouds9, cldsa, mtopa, mbota, de_lgth, alb1d, & ! OUT - optical_props_clouds, optical_props_aerosol, gas_concentrations, errmsg, errflg) + optical_props_clouds, optical_props_aerosol, gas_concentrations, sfc_emiss_byband, errmsg, errflg) use physparam use machine, only: & @@ -153,9 +154,9 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup progclduni ! Unified cloud-scheme use surface_perturbation, only: & cdfnor ! Routine to compute CDF (used to compute percentiles) - use rrtmgp_lw_pre, only: & - nrghice, ipsdlw0 - use rrtmgp_lw, only: check_error_msg + use module_radiation_surface, only: & + setemis ! Routine to compute surface-emissivity + use rrtmgp_lw, only: check_error_msg, nrghice, ipsdlw0 use mersenne_twister, only: & random_setseed, & random_number, & @@ -185,7 +186,7 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup type(ty_cloud_optics),intent(in) :: & kdist_cldy_lw, & kdist_cldy_sw - type(ty_gas_concs),intent(inout) :: & + type(ty_gas_concs),intent(out) :: & gas_concentrations integer,intent(in),dimension(IM) :: & icseed ! auxiliary special cloud related array when module @@ -220,14 +221,15 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup type(ty_optical_props_1scl),intent(out) :: & optical_props_clouds, & optical_props_aerosol + real(kind_phys),dimension(kdist_lw%get_nband(),Model%levr+LTP),intent(out) :: sfc_emiss_byband ! Local variables integer :: me, nfxr, ntrac, ntcw, ntiw, ncld, ntrw, ntsw, ntgl,i, j, k, k1, k2, lsk, & - lv, n, itop, ibtc, LP1, lla, llb, lya, lyb, iCol + lv, n, itop, ibtc, LP1, lla, llb, lya, lyb, iCol, iBand integer,dimension(IM) :: ipseed - logical,dimension(IM,LMK) :: & + logical,dimension(IM,Model%levr+LTP) :: & liqmask,icemask - real(kind_phys),dimension(IM,LMK) :: & + real(kind_phys),dimension(IM,Model%levr+LTP) :: & cld_ref_ice2,cld_ref_liq2, vmr_o3, vmr_h2o real(kind_phys) :: es, qs, delt, tem0d real(kind_phys), dimension(size(Grid%xlon,1)) :: cvt1, cvb1, tem1d, tskn @@ -244,11 +246,11 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup real(kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,kdist_sw%get_nband(),NF_AESW)::faersw real(kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,kdist_lw%get_nband(),NF_AELW)::faerlw type(ty_optical_props_1scl) :: optical_props_clear, optical_props_cloudsByBand - real(kind_phys), dimension(kdist_lw%get_nband(),LMK,IM) :: & + real(kind_phys), dimension(kdist_lw%get_ngpt(),Model%levr+LTP,IM) :: & rng3D - real(kind_phys), dimension(kdist_lw%get_nband()*LMK) :: & + real(kind_phys), dimension(kdist_lw%get_ngpt()*(Model%levr+LTP)) :: & rng1D - logical, dimension(IM,LMK,kdist_lw%get_nband()) :: & + logical, dimension(IM,Model%levr+LTP,kdist_lw%get_ngpt()) :: & cldfracMCICA type(random_stat) :: rng_stat @@ -307,17 +309,9 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup if ( itsfc == 0 ) then ! use same sfc skin-air/ground temp tskn(1:IM) = Sfcprop%tsfc(1:IM) tsfg(1:IM) = Sfcprop%tsfc(1:IM) -! do i = 1, IM -! tskn(i) = Sfcprop%tsfc(i) -! tsfg(i) = Sfcprop%tsfc(i) -! enddo else ! use diff sfc skin-air/ground temp tskn(1:IM) = Sfcprop%tsfc(1:IM) tsfg(1:IM) = Sfcprop%tsfc(1:IM) -! do i = 1, IM -! tskn(i) = Sfcprop%tsfc(i) -! tsfg(i) = Sfcprop%tsfc(i) -! enddo endif ! Prepare atmospheric profiles for radiation input. @@ -754,6 +748,17 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup endif ! mg, sfc-perts + ! ####################################################################################### + ! Call module_radiation_surface::setemis(),to setup surface emissivity for LW radiation. + ! ####################################################################################### + if (Model%lslwr) then + call setemis (Grid%xlon, Grid%xlat, Sfcprop%slmsk, Sfcprop%snowd, Sfcprop%sncovr, & + Sfcprop%zorl, tsfg, tsfa, Sfcprop%hprim, IM, Radtend%semis) + do iBand=1,kdist_lw%get_nband() + sfc_emiss_byband(iBand,1:IM) = Radtend%semis(1:IM) + enddo + endif + ! ####################################################################################### ! Compute radiative properties needed for RRTMGP ! ####################################################################################### @@ -786,16 +791,16 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup where(cld_ref_liq2 .lt. kdist_cldy_lw%get_min_radius_liq()) cld_ref_liq2=kdist_cldy_lw%get_min_radius_liq() ! Allocate space for gas optical properties [ncol,nlay,ngpts] - call check_error_msg(optical_props_clear%alloc_1scl( IM, LMK, kdist_lw)) ! Cloud optics [nCol,nLay,nBands] - call check_error_msg(optical_props_cloudsByBand%init(optical_props_clear%get_band_lims_wavenumber())) + print*,'In GFS_rrtmgp_pre: ' + call check_error_msg(optical_props_cloudsByBand%init(kdist_lw%get_band_lims_wavenumber())) call check_error_msg(optical_props_cloudsByBand%alloc_1scl(IM, LMK)) ! Aerosol optics [Ccol,nLay,nBands] - call check_error_msg(optical_props_aerosol%init(optical_props_clear%get_band_lims_wavenumber())) + call check_error_msg(optical_props_aerosol%init(kdist_lw%get_band_lims_wavenumber())) call check_error_msg(optical_props_aerosol%alloc_1scl(IM, LMK)) ! Cloud optics [nCol,nLay,nGpts] call check_error_msg(optical_props_clouds%alloc_1scl(IM, LMK, kdist_lw)) - + ! Set gas concentrations call gas_concentrations%reset() call check_error_msg(gas_concentrations%set_vmr('o2', gasvmr_o2)) @@ -834,8 +839,6 @@ subroutine GFS_rrtmgp_pre_run (Model, Grid, Sfcprop, Statein, Tbd, Cldprop, Coup call check_error_msg(draw_samples(cldfracMCICA,optical_props_cloudsByBand,optical_props_clouds)) endif - - end subroutine GFS_rrtmgp_pre_run !> \section arg_table_GFS_rrtmgp_pre_finalize Argument Table diff --git a/physics/rrtmgp_lw.F90 b/physics/rrtmgp_lw.F90 index 6140924fe..183bc8db6 100644 --- a/physics/rrtmgp_lw.F90 +++ b/physics/rrtmgp_lw.F90 @@ -2,6 +2,8 @@ ! ########################################################################################### module rrtmgp_lw use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type + use mo_rte_kind, only: wl use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_cloud_optics, only: ty_cloud_optics use mo_optical_props, only: ty_optical_props_1scl @@ -9,36 +11,679 @@ module rrtmgp_lw use mo_gas_concentrations, only: ty_gas_concs use mo_fluxes_byband, only: ty_fluxes_byband + ! Parameters + integer,parameter :: nGases = 6 + real(kind_phys),parameter :: epsilon=1.0e-6 + character(len=3),parameter, dimension(nGases) :: & + active_gases = (/ 'h2o', 'co2', 'o3 ', 'n2o', 'ch4', 'o2 '/) + integer :: nrghice, ipsdlw0 + public rrtmgp_lw_init, rrtmgp_lw_run, rrtmgp_lw_finalize contains - subroutine rrtmgp_lw_init() +!! \section arg_table_rrtmgp_lw_init 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 | +!! | mpirank | mpi_rank | current MPI rank | index | 0 | integer | | in | F | +!! | mpiroot | mpi_root | master MPI rank | index | 0 | integer | | in | F | +!! | 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 | +!! | kdist_lw | K_distribution_file_for_RRTMGP_LW_scheme | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | inout | F | +!! | kdist_cldy_lw | K_distribution_file_for_cloudy_RRTMGP_LW_scheme | DDT containing spectral information for cloudy RRTMGP LW radiation scheme | DDT | 0 | ty_cloud_optics | | inout | F | +!! + ! ######################################################################################### + subroutine rrtmgp_lw_init(Model, mpicomm, mpirank, mpiroot, kdist_lw, kdist_cldy_lw, & + errmsg, errflg) + use netcdf + +#ifdef MPI + use mpi +#endif + + ! Inputs + type(GFS_control_type), intent(in) :: & + Model ! DDT containing model control parameters + integer,intent(in) :: & + mpicomm, & ! MPI communicator + mpirank, & ! Current MPI rank + mpiroot ! Master MPI rank + type(ty_gas_optics_rrtmgp),intent(inout) :: & + kdist_lw + type(ty_cloud_optics),intent(inout) :: & + kdist_cldy_lw + + ! Outputs + character(len=*), intent(out) :: & + errmsg ! Error message + integer, intent(out) :: & + errflg ! Error code + + ! Variables that will be passed to gas_optics%load() + type(ty_gas_concs) :: & + gas_concentrations + integer, dimension(:), allocatable :: & + kminor_start_lower, & ! used by RRTGMP gas optics + kminor_start_upper ! used by RRTGMP gas optics + integer, dimension(:,:), allocatable :: & + band2gpt, & ! used by RRTGMP gas optics + minor_limits_gpt_lower, & ! used by RRTGMP gas optics + minor_limits_gpt_upper ! used by RRTGMP gas optics + integer, dimension(:,:,:), allocatable :: & + key_species ! used by RRTGMP gas optics + real(kind_phys) :: & + press_ref_trop, & ! used by RRTGMP gas optics + temp_ref_p, & ! used by RRTGMP gas optics + temp_ref_t, & ! used by RRTGMP gas optics + radliq_lwr, & ! used by RRTGMP cloud optics + radliq_upr, & ! used by RRTGMP cloud optics + radliq_fac, & ! used by RRTGMP cloud optics + radice_lwr, & ! used by RRTGMP cloud optics + radice_upr, & ! used by RRTGMP cloud optics + radice_fac ! used by RRTGMP cloud optics + real(kind_phys), dimension(:), allocatable :: & + press_ref, & ! used by RRTGMP gas optics + temp_ref, & ! used by RRTGMP gas optics + pade_sizereg_extliq, & ! used by RRTGMP cloud optics + pade_sizereg_ssaliq, & ! used by RRTGMP cloud optics + pade_sizereg_asyliq, & ! used by RRTGMP cloud optics + pade_sizereg_extice, & ! used by RRTGMP cloud optics + pade_sizereg_ssaice, & ! used by RRTGMP cloud optics + pade_sizereg_asyice ! used by RRTGMP cloud optics + real(kind_phys), dimension(:,:), allocatable :: & + band_lims, & ! used by RRTGMP gas optics + totplnk, & ! used by RRTGMP gas optics + lut_extliq, & ! used by RRTGMP cloud optics + lut_ssaliq, & ! used by RRTGMP cloud optics + lut_asyliq, & ! used by RRTGMP cloud optics + band_lims_cldy ! used by RRTGMP cloud optics + + real(kind_phys), dimension(:,:,:), allocatable :: & + vmr_ref, & ! used by RRTGMP gas optics + kminor_lower, & ! used by RRTGMP gas optics + kminor_upper, & ! used by RRTGMP gas optics + rayl_lower, & ! used by RRTGMP gas optics + rayl_upper, & ! used by RRTGMP gas optics + lut_extice, & ! used by RRTGMP cloud optics + lut_ssaice, & ! used by RRTGMP cloud optics + lut_asyice, & ! used by RRTGMP cloud optics + pade_extliq, & ! used by RRTGMP cloud optics + pade_ssaliq, & ! used by RRTGMP cloud optics + pade_asyliq ! used by RRTGMP cloud optics + real(kind_phys), dimension(:,:,:,:), allocatable :: & + kmajor, & ! used by RRTGMP gas optics + planck_frac, & ! used by RRTGMP gas optics + pade_extice, & ! used by RRTGMP cloud optics + pade_ssaice, & ! used by RRTGMP cloud optics + pade_asyice ! used by RRTGMP cloud optics + character(len=32), dimension(:), allocatable :: & + gas_names, & ! used by RRTGMP gas optics + gas_minor, & ! used by RRTGMP gas optics + identifier_minor, & ! used by RRTGMP gas optics + minor_gases_lower, & ! used by RRTGMP gas optics + minor_gases_upper, & ! used by RRTGMP gas optics + scaling_gas_lower, & ! used by RRTGMP gas optics + scaling_gas_upper ! used by RRTGMP gas optics + logical(wl), dimension(:), allocatable :: & + minor_scales_with_density_lower, & ! used by RRTGMP gas optics + minor_scales_with_density_upper, & ! used by RRTGMP gas optics + scale_by_complement_lower, & ! used by RRTGMP gas optics + scale_by_complement_upper ! used by RRTGMP gas optics + + ! Dimensions (to be broadcast across all processors) + integer :: & + ntemps, & ! used by RRTGMP gas optics + npress, & ! used by RRTGMP gas optics + nabsorbers, & ! used by RRTGMP gas optics + nextrabsorbers, & ! used by RRTGMP gas optics + nminorabsorbers, & ! used by RRTGMP gas optics + nmixingfracs, & ! used by RRTGMP gas optics + nlayers, & ! used by RRTGMP gas optics + nbnds, & ! used by RRTGMP gas optics + ngpts, & ! used by RRTGMP gas optics + npairs, & ! used by RRTGMP gas optics + ninternalSourcetemps, & ! used by RRTGMP gas optics + nminor_absorber_intervals_lower, & ! used by RRTGMP gas optics + nminor_absorber_intervals_upper, & ! used by RRTGMP gas optics + ncontributors_lower, & ! used by RRTGMP gas optics + ncontributors_upper, & ! used by RRTGMP gas optics + nbandLWcldy, & ! used by RRTGMP cloud optics + nsize_liq, & ! used by RRTGMP cloud optics + nsize_ice, & ! used by RRTGMP cloud optics + nsizereg, & ! used by RRTGMP cloud optics + ncoeff_ext, & ! used by RRTGMP cloud optics + ncoeff_ssa_g, & ! used by RRTGMP cloud optics + nbound, & ! used by RRTGMP cloud optics + npairsLWcldy ! used by RRTGMP cloud optics + + ! Local variables + integer :: ncid_lw,dimID,varID,status,igpt,iGas,ij,ierr,ncid_lw_clds + integer,dimension(:),allocatable :: temp1,temp2,temp3,temp4,temp_log_array1,& + temp_log_array2, temp_log_array3, temp_log_array4 + character(len=264) :: kdist_file,kdist_cldy_file + integer,parameter :: max_strlen=256 + + ! Initialize + errmsg = '' + errflg = 0 + + ! How are we handling cloud-optics? + rrtmgp_lw_cld_phys = Model%rrtmgp_cld_phys + + ! Filenames are set in the gfs_physics_nml (scm/src/GFS_typedefs.F90) + kdist_file = trim(Model%rrtmgp_root)//trim(Model%kdist_lw_file_gas) + kdist_cldy_file = trim(Model%rrtmgp_root)//trim(Model%kdist_lw_file_clouds) + + ! Read dimensions for k-distribution fields (only on master processor(0)) + if (mpirank .eq. mpiroot) then + if(nf90_open(trim(kdist_file), NF90_WRITE, ncid_lw) .eq. NF90_NOERR) then + status = nf90_inq_dimid(ncid_lw, 'temperature', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=ntemps) + status = nf90_inq_dimid(ncid_lw, 'pressure', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=npress) + status = nf90_inq_dimid(ncid_lw, 'absorber', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=nabsorbers) + status = nf90_inq_dimid(ncid_lw, 'minor_absorber', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=nminorabsorbers) + status = nf90_inq_dimid(ncid_lw, 'absorber_ext', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=nextrabsorbers) + status = nf90_inq_dimid(ncid_lw, 'mixing_fraction', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=nmixingfracs) + status = nf90_inq_dimid(ncid_lw, 'atmos_layer', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=nlayers) + status = nf90_inq_dimid(ncid_lw, 'bnd', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=nbnds) + status = nf90_inq_dimid(ncid_lw, 'gpt', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=ngpts) + status = nf90_inq_dimid(ncid_lw, 'pair', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=npairs) + status = nf90_inq_dimid(ncid_lw, 'contributors_lower', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=ncontributors_lower) + status = nf90_inq_dimid(ncid_lw, 'contributors_upper', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=ncontributors_upper) + status = nf90_inq_dimid(ncid_lw, 'minor_absorber_intervals_lower', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=nminor_absorber_intervals_lower) + status = nf90_inq_dimid(ncid_lw, 'minor_absorber_intervals_upper', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=nminor_absorber_intervals_upper) + status = nf90_inq_dimid(ncid_lw, 'temperature_Planck', dimid) + status = nf90_inquire_dimension(ncid_lw, dimid, len=ninternalSourcetemps) + status = nf90_close(ncid_lw) + endif + endif + + ! Broadcast dimensions to all processors +#ifdef MPI + call MPI_BCAST(ntemps, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(npress, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nabsorbers, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nminorabsorbers, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nextraabsorbers, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nmixingfracs, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nlayers, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nbnds, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(ngpts, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(npairs, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(ncontributors_lower, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(ncontributors_upper, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nminor_absorber_intervals_lower, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nminor_absorber_intervals_upper, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(ninternalSourcetemps, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) +#endif + + !if (mpirank .eq. mpiroot) then + ! 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(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)) + + if (mpirank .eq. mpiroot) then + ! Read in fields from file + if(nf90_open(trim(kdist_file), NF90_WRITE, ncid_lw) .eq. NF90_NOERR) then + status = nf90_inq_varid(ncid_lw,'gas_names',varID) + status = nf90_get_var(ncid_lw,varID,gas_names) + ! + status = nf90_inq_varid(ncid_lw,'scaling_gas_lower',varID) + status = nf90_get_var(ncid_lw,varID,scaling_gas_lower) + ! + status = nf90_inq_varid(ncid_lw,'scaling_gas_upper',varID) + status = nf90_get_var(ncid_lw,varID,scaling_gas_upper) + ! + status = nf90_inq_varid(ncid_lw,'gas_minor',varID) + status = nf90_get_var(ncid_lw,varID,gas_minor) + ! + status = nf90_inq_varid(ncid_lw,'identifier_minor',varID) + status = nf90_get_var(ncid_lw,varID,identifier_minor) + ! + status = nf90_inq_varid(ncid_lw,'minor_gases_lower',varID) + status = nf90_get_var(ncid_lw,varID,minor_gases_lower) + ! + status = nf90_inq_varid(ncid_lw,'minor_gases_upper',varID) + status = nf90_get_var(ncid_lw,varID,minor_gases_upper) + ! + status = nf90_inq_varid(ncid_lw,'minor_limits_gpt_lower',varID) + status = nf90_get_var(ncid_lw,varID,minor_limits_gpt_lower) + ! + status = nf90_inq_varid(ncid_lw,'minor_limits_gpt_upper',varID) + status = nf90_get_var(ncid_lw,varID,minor_limits_gpt_upper) + ! + status = nf90_inq_varid(ncid_lw,'bnd_limits_gpt',varID) + status = nf90_get_var(ncid_lw,varID,band2gpt) + ! + status = nf90_inq_varid(ncid_lw,'key_species',varID) + status = nf90_get_var(ncid_lw,varID,key_species) + ! + status = nf90_inq_varid(ncid_lw,'bnd_limits_wavenumber',varID) + status = nf90_get_var(ncid_lw,varID,band_lims) + ! + status = nf90_inq_varid(ncid_lw,'press_ref',varID) + status = nf90_get_var(ncid_lw,varID,press_ref) + ! + status = nf90_inq_varid(ncid_lw,'temp_ref',varID) + status = nf90_get_var(ncid_lw,varID,temp_ref) + ! + status = nf90_inq_varid(ncid_lw,'absorption_coefficient_ref_P',varID) + status = nf90_get_var(ncid_lw,varID,temp_ref_p) + ! + status = nf90_inq_varid(ncid_lw,'absorption_coefficient_ref_T',varID) + status = nf90_get_var(ncid_lw,varID,temp_ref_t) + ! + status = nf90_inq_varid(ncid_lw,'press_ref_trop',varID) + status = nf90_get_var(ncid_lw,varID,press_ref_trop) + ! + status = nf90_inq_varid(ncid_lw,'kminor_lower',varID) + status = nf90_get_var(ncid_lw,varID,kminor_lower) + ! + status = nf90_inq_varid(ncid_lw,'kminor_upper',varID) + status = nf90_get_var(ncid_lw,varID,kminor_upper) + ! + status = nf90_inq_varid(ncid_lw,'vmr_ref',varID) + status = nf90_get_var(ncid_lw,varID,vmr_ref) + ! + status = nf90_inq_varid(ncid_lw,'kmajor',varID) + status = nf90_get_var(ncid_lw,varID,kmajor) + ! + status = nf90_inq_varid(ncid_lw,'kminor_start_lower',varID) + status = nf90_get_var(ncid_lw,varID,kminor_start_lower) + ! + status = nf90_inq_varid(ncid_lw,'kminor_start_upper',varID) + status = nf90_get_var(ncid_lw,varID,kminor_start_upper) + ! + status = nf90_inq_varid(ncid_lw,'totplnk',varID) + status = nf90_get_var(ncid_lw,varID,totplnk) + ! + status = nf90_inq_varid(ncid_lw,'plank_fraction',varID) + status = nf90_get_var(ncid_lw,varID,planck_frac) + + ! Logical fields are read in as integers and then converted to logicals. + status = nf90_inq_varid(ncid_lw,'minor_scales_with_density_lower',varID) + status = nf90_get_var(ncid_lw,varID,temp1) + minor_scales_with_density_lower(:) = .false. + where(temp1 .eq. 1) minor_scales_with_density_lower(:) = .true. + ! + status = nf90_inq_varid(ncid_lw,'minor_scales_with_density_upper',varID) + status = nf90_get_var(ncid_lw,varID,temp2) + minor_scales_with_density_upper(:) = .false. + where(temp2 .eq. 1) minor_scales_with_density_upper(:) = .true. + ! + status = nf90_inq_varid(ncid_lw,'scale_by_complement_lower',varID) + status = nf90_get_var(ncid_lw,varID,temp3) + scale_by_complement_lower(:) = .false. + where(temp3 .eq. 1) scale_by_complement_lower(:) = .true. + ! + status = nf90_inq_varid(ncid_lw,'scale_by_complement_upper',varID) + status = nf90_get_var(ncid_lw,varID,temp4) + scale_by_complement_upper(:) = .false. + where(temp4 .eq. 1) scale_by_complement_upper(:) = .true. + + ! Close + status = nf90_close(ncid_lw) + endif + endif + + ! Broadcast arrays to all processors +#ifdef MPI + call MPI_BCAST(minor_limits_gpt_upper, size(minor_limits_gpt_upper), MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(minor_limits_gpt_lower, size(minor_limits_gpt_lower), MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(kminor_start_upper, size(kminor_start_upper), MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(kminor_start_lower, size(kminor_start_lower), MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(key_species, size(key_species), MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(band2gpt, size(band2gpt), MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(band_lims, size(band_lims), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(press_ref, size(press_ref), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(temp_ref, size(temp_ref), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(kminor_lower, size(kminor_lower), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(kminor_upper, size(kminor_upper), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(scaling_gas_lower, size(scaling_gas_lower), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(scaling_gas_upper, size(scaling_gas_upper), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(vmr_ref, size(vmr_ref), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(kmajor, size(kmajor), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(temp_ref_p, 1, kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(temp_ref_t, 1, kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(press_ref_trop, 1, kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(totplnk, size(totplnk), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(planck_frac, size(planck_frac), kind_phys, mpiroot, mpicomm, ierr) + ! Character arrays + do ij=1,nabsorbers + call MPI_BCAST(gas_names(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) + enddo + do ij=1,nminorabsorbers + call MPI_BCAST(gas_minor(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) + call MPI_BCAST(identifier_minor(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) + enddo + do ij=1,nminor_absorber_intervals_lower + call MPI_BCAST(minor_gases_lower(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) + enddo + do ij=1,nminor_absorber_intervals_upper + call MPI_BCAST(minor_gases_upper(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) + enddo + ! Logical arrays (First convert to integer-array, then broadcast) + ! + allocate(temp_log_array1(nminor_absorber_intervals_lower)) + where(minor_scales_with_density_lower) + temp_log_array1 = 1 + elsewhere + temp_log_array1 = 0 + end where + call MPI_BCAST(temp_log_array1, size(temp_log_array1), MPI_INTEGER, mpiroot, mpicomm, ierr) + ! + allocate(temp_log_array2(nminor_absorber_intervals_lower)) + where(scale_by_complement_lower) + temp_log_array2 = 1 + elsewhere + temp_log_array2 = 0 + end where + call MPI_BCAST(temp_log_array2, size(temp_log_array2), MPI_INTEGER, mpiroot, mpicomm, ierr) + ! + allocate(temp_log_array3(nminor_absorber_intervals_upper)) + where(minor_scales_with_density_upper) + temp_log_array3 = 1 + elsewhere + temp_log_array3 = 0 + end where + call MPI_BCAST(temp_log_array3, size(temp_log_array3), MPI_INTEGER, mpiroot, mpicomm, ierr) + ! + allocate(temp_log_array4(nminor_absorber_intervals_upper)) + where(scale_by_complement_upper) + temp_log_array4 = 1 + elsewhere + temp_log_array4 = 0 + end where + call MPI_BCAST(temp_log_array4, size(temp_log_array4), MPI_INTEGER, mpiroot, mpicomm, ierr) +#endif + + ! Initialize gas concentrations and gas optics class with data + do iGas=1,nGases + call check_error_msg(gas_concentrations%set_vmr(active_gases(iGas), 0._kind_phys)) + enddo + call check_error_msg(kdist_lw%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)) + + ! Set initial permutation seed for McICA, initially set to number of G-points + ipsdlw0 = kdist_lw%get_ngpt() + + ! ####################################################################################### + ! If RRTMGP cloud-optics are requested, read tables and broadcast. + ! ####################################################################################### + ! Read dimensions for k-distribution fields (only on master processor(0)) + if (mpirank .eq. mpiroot) then + if(nf90_open(trim(kdist_cldy_file), NF90_WRITE, ncid_lw_clds) == NF90_NOERR) then + status = nf90_inq_dimid(ncid_lw_clds, 'nband', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nbandLWcldy) + status = nf90_inq_dimid(ncid_lw_clds, 'nrghice', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nrghice) + status = nf90_inq_dimid(ncid_lw_clds, 'nsize_liq', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nsize_liq) + status = nf90_inq_dimid(ncid_lw_clds, 'nsize_ice', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nsize_ice) + status = nf90_inq_dimid(ncid_lw_clds, 'nsizereg', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nsizereg) + status = nf90_inq_dimid(ncid_lw_clds, 'ncoeff_ext', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=ncoeff_ext) + status = nf90_inq_dimid(ncid_lw_clds, 'ncoeff_ssa_g', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=ncoeff_ssa_g) + status = nf90_inq_dimid(ncid_lw_clds, 'nbound', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nbound) + status = nf90_inq_dimid(ncid_lw_clds, 'pair', dimid) + status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=npairsLWcldy) + status = nf90_close(ncid_lw_clds) + endif + endif + + ! Broadcast dimensions to all processors +#ifdef MPI + if (rrtmgp_lw_cld_phys .eq. 1 .or. rrtmgp_lw_cld_phys .eq. 2) then + call MPI_BCAST(nbandLWcldy, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nrghice, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nsize_liq, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nsize_ice, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nsizereg, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(ncoeff_ext, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(ncoeff_ssa_g, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(nbound, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + call MPI_BCAST(npairsLWcldy, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) + endif +#endif + + if (rrtmgp_lw_cld_phys .eq. 1) then + allocate(lut_extliq(nsize_liq, nBandLWcldy)) + allocate(lut_ssaliq(nsize_liq, nBandLWcldy)) + allocate(lut_asyliq(nsize_liq, nBandLWcldy)) + allocate(lut_extice(nsize_ice, nBandLWcldy, nrghice)) + allocate(lut_ssaice(nsize_ice, nBandLWcldy, nrghice)) + allocate(lut_asyice(nsize_ice, nBandLWcldy, nrghice)) + allocate(band_lims_cldy(2, nBandLWcldy)) + endif + if (rrtmgp_lw_cld_phys .eq. 2) then + allocate(pade_extliq(nbandLWcldy, nsizereg, ncoeff_ext )) + allocate(pade_ssaliq(nbandLWcldy, nsizereg, ncoeff_ssa_g)) + allocate(pade_asyliq(nbandLWcldy, nsizereg, ncoeff_ssa_g)) + allocate(pade_extice(nbandLWcldy, nsizereg, ncoeff_ext, nrghice)) + allocate(pade_ssaice(nbandLWcldy, nsizereg, ncoeff_ssa_g, nrghice)) + allocate(pade_asyice(nbandLWcldy, nsizereg, ncoeff_ssa_g, nrghice)) + 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(band_lims_cldy(2,nbandLWcldy)) + endif + + ! On master processor, allocate space, read in fields, broadcast to all processors + if (mpirank .eq. mpiroot) then + ! + if (rrtmgp_lw_cld_phys .eq. 1) then + ! + if(nf90_open(trim(kdist_cldy_file), NF90_WRITE, ncid_lw_clds) == NF90_NOERR) then + status = nf90_inq_varid(ncid_lw_clds,'radliq_lwr',varID) + status = nf90_get_var(ncid_lw_clds,varID,radliq_lwr) + status = nf90_inq_varid(ncid_lw_clds,'radliq_upr',varID) + status = nf90_get_var(ncid_lw_clds,varID,radliq_upr) + status = nf90_inq_varid(ncid_lw_clds,'radliq_fac',varID) + status = nf90_get_var(ncid_lw_clds,varID,radliq_fac) + status = nf90_inq_varid(ncid_lw_clds,'radice_lwr',varID) + status = nf90_get_var(ncid_lw_clds,varID,radice_lwr) + status = nf90_inq_varid(ncid_lw_clds,'radice_upr',varID) + status = nf90_get_var(ncid_lw_clds,varID,radice_upr) + status = nf90_inq_varid(ncid_lw_clds,'radice_fac',varID) + status = nf90_get_var(ncid_lw_clds,varID,radice_fac) + status = nf90_inq_varid(ncid_lw_clds,'lut_extliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,lut_extliq) + status = nf90_inq_varid(ncid_lw_clds,'lut_ssaliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,lut_ssaliq) + status = nf90_inq_varid(ncid_lw_clds,'lut_asyliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,lut_asyliq) + status = nf90_inq_varid(ncid_lw_clds,'lut_extice',varID) + status = nf90_get_var(ncid_lw_clds,varID,lut_extice) + status = nf90_inq_varid(ncid_lw_clds,'lut_ssaice',varID) + status = nf90_get_var(ncid_lw_clds,varID,lut_ssaice) + status = nf90_inq_varid(ncid_lw_clds,'lut_asyice',varID) + status = nf90_get_var(ncid_lw_clds,varID,lut_asyice) + status = nf90_inq_varid(ncid_lw_clds,'bnd_limits_wavenumber',varID) + status = nf90_get_var(ncid_lw_clds,varID,band_lims_cldy) + status = nf90_close(ncid_lw_clds) + endif + endif + ! + if (rrtmgp_lw_cld_phys .eq. 2) then + ! + if(nf90_open(trim(kdist_cldy_file), NF90_WRITE, ncid_lw_clds) == NF90_NOERR) then + status = nf90_inq_varid(ncid_lw_clds,'radliq_lwr',varID) + status = nf90_get_var(ncid_lw_clds,varID,radliq_lwr) + status = nf90_inq_varid(ncid_lw_clds,'radliq_upr',varID) + status = nf90_get_var(ncid_lw_clds,varID,radliq_upr) + status = nf90_inq_varid(ncid_lw_clds,'radliq_fac',varID) + status = nf90_get_var(ncid_lw_clds,varID,radliq_fac) + status = nf90_inq_varid(ncid_lw_clds,'radice_lwr',varID) + status = nf90_get_var(ncid_lw_clds,varID,radice_lwr) + status = nf90_inq_varid(ncid_lw_clds,'radice_upr',varID) + status = nf90_get_var(ncid_lw_clds,varID,radice_upr) + status = nf90_inq_varid(ncid_lw_clds,'radice_fac',varID) + status = nf90_get_var(ncid_lw_clds,varID,radice_fac) + status = nf90_inq_varid(ncid_lw_clds,'pade_extliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_extliq) + status = nf90_inq_varid(ncid_lw_clds,'pade_ssaliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_ssaliq) + status = nf90_inq_varid(ncid_lw_clds,'pade_asyliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_asyliq) + status = nf90_inq_varid(ncid_lw_clds,'pade_extice',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_extice) + status = nf90_inq_varid(ncid_lw_clds,'pade_ssaice',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_ssaice) + status = nf90_inq_varid(ncid_lw_clds,'pade_asyice',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_asyice) + status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_extliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_extliq) + status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_ssaliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_ssaliq) + status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_asyliq',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_asyliq) + status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_extice',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_extice) + status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_ssaice',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_ssaice) + status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_asyice',varID) + status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_asyice) + status = nf90_inq_varid(ncid_lw_clds,'bnd_limits_wavenumber',varID) + status = nf90_get_var(ncid_lw_clds,varID,band_lims_cldy) + status = nf90_close(ncid_lw_clds) + endif + endif + endif + + ! Broadcast arrays to all processors +#ifdef MPI + if (rrtmgp_lw_cld_phys .eq. 1) then + call MPI_BCAST(radliq_lwr, size(radliq_lwr), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(radliq_upr, size(radliq_upr), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(radliq_fac, size(radliq_fac), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(radice_lwr, size(radice_lwr), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(radice_upr, size(radice_upr), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(radice_fac, size(radice_fac), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(lut_extliq, size(lut_extliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(lut_ssaliq, size(lut_ssaliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(lut_asyliq, size(lut_asyliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(lut_extice, size(lut_extice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(lut_ssaice, size(lut_ssaice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(lut_asyice, size(lut_asyice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(band_lims_cldy), size(band_lims_cldy), kind_phys, mpiroot, mpicomm, ierr) + endif + if (rrtmgp_lw_cld_phys .eq. 2) then + call MPI_BCAST(pade_extliq, size(pade_extliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_ssaliq, size(pade_ssaliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_asyliq, size(pade_asyliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_extice, size(pade_extice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_ssaice, size(pade_ssaice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_asyice, size(pade_asyice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_sizereg_extliq), size(pade_sizereg_extliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_sizereg_ssaliq), size(pade_sizereg_ssaliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_sizereg_asyliq), size(pade_sizereg_asyliq), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_sizereg_extice), size(pade_sizereg_extice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_sizereg_ssaice), size(pade_sizereg_ssaice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(pade_sizereg_asyice), size(pade_sizereg_asyice), kind_phys, mpiroot, mpicomm, ierr) + call MPI_BCAST(band_lims_cldy), size(band_lims_cldy), kind_phys, mpiroot, mpicomm, ierr) + endif +#endif + + ! Load tables data for RRTGMP cloud-optics + if (rrtmgp_lw_cld_phys .eq. 1) then + call check_error_msg(kdist_cldy_lw%set_ice_roughness(nrghice)) + call check_error_msg(kdist_cldy_lw%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 (rrtmgp_lw_cld_phys .eq. 2) then + call check_error_msg(kdist_cldy_lw%set_ice_roughness(nrghice)) + call check_error_msg(kdist_cldy_lw%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, & + pade_sizereg_extice, pade_sizereg_ssaice, pade_sizereg_asyice)) + endif + end subroutine rrtmgp_lw_init ! ######################################################################################### ! ######################################################################################### !! \section arg_table_rrtmgp_lw_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |-----------------------|-------------------------------------------------|--------------------------------------------------------------------|-------|------|-----------------------|-----------|--------|----------| -!! | ncol | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | -!! | nlay | adjusted_vertical_layer_dimension_for_radiation | number of vertical layers for radiation | count | 0 | integer | | in | F | -!! | p_lay | air_pressure_at_layer_for_radiation_in_hPa | air pressure layer | hPa | 2 | real | kind_phys | in | F | -!! | p_lev | air_pressure_at_interface_for_radiation_in_hPa | air pressure level | hPa | 2 | real | kind_phys | in | F | -!! | t_lay | air_temperature_at_layer_for_radiation | air temperature layer | K | 2 | real | kind_phys | in | F | -!! | skt | surface_ground_temperature_for_radiation | surface ground temperature for radiation | K | 1 | real | kind_phys | in | F | -!! | sfc_emiss | surface_longwave_emissivity_in_each_band | surface lw emissivity in fraction in each LW band | frac | 2 | real | kind_phys | in | F | -!! | kdist_lw | K_distribution_file_for_RRTMGP_LW_scheme | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | in | F | -!! | optical_props_clds | optical_properties_for_cloudy_atmosphere | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_1scl | | in | F | -!! | optical_props_aerosol | optical_properties_for_aerosols | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_1scl | | in | F | -!! | gas_concentrations | Gas_concentrations_for_RRTMGP_suite | DDT containing gas concentrations for RRTMGP radiation scheme | DDT | 0 | ty_gas_concs | | in | F | -!! | fluxLW_allsky | lw_flux_profiles_byband_allsky | Fortran DDT containing RRTMGP 3D fluxes | DDT | 0 | ty_fluxes_byband | | out | F | -!! | fluxLW_clrsky | lw_flux_profiles_byband_clrsky | Fortran DDT containing RRTMGP 3D fluxes | DDT | 0 | ty_fluxes_byband | | out | 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 | +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |-----------------------|-----------------------------------------------------------------------------------------------|--------------------------------------------------------------------|-------|------|-----------------------|-----------|--------|----------| +!! | ncol | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | +!! | nlay | adjusted_vertical_layer_dimension_for_radiation | number of vertical layers for radiation | count | 0 | integer | | in | F | +!! | p_lay | air_pressure_at_layer_for_radiation_in_hPa | air pressure layer | hPa | 2 | real | kind_phys | in | F | +!! | p_lev | air_pressure_at_interface_for_radiation_in_hPa | air pressure level | hPa | 2 | real | kind_phys | in | F | +!! | t_lay | air_temperature_at_layer_for_radiation | air temperature layer | K | 2 | real | kind_phys | in | F | +!! | skt | surface_ground_temperature_for_radiation | surface ground temperature for radiation | K | 1 | real | kind_phys | in | F | +!! | sfc_emiss | surface_longwave_emissivity_in_each_band | surface lw emissivity in fraction in each LW band | frac | 2 | real | kind_phys | in | F | +!! | kdist_lw | K_distribution_file_for_RRTMGP_LW_scheme | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | in | F | +!! | optical_props_clds | optical_properties_for_cloudy_atmosphere | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_1scl | | in | F | +!! | optical_props_aerosol | optical_properties_for_aerosols | Fortran DDT containing RRTMGP optical properties | DDT | 0 | ty_optical_props_1scl | | in | F | +!! | gas_concentrations | Gas_concentrations_for_RRTMGP_suite | DDT containing gas concentrations for RRTMGP radiation scheme | DDT | 0 | ty_gas_concs | | in | F | +!! | lslwr | flag_to_calc_lw | flag to calculate LW irradiances | flag | 0 | logical | | in | F | +!! | fluxLW_allsky | lw_flux_profiles_byband_allsky | Fortran DDT containing RRTMGP 3D fluxes | DDT | 0 | ty_fluxes_byband | | out | F | +!! | fluxLW_clrsky | lw_flux_profiles_byband_clrsky | Fortran DDT containing RRTMGP 3D fluxes | DDT | 0 | ty_fluxes_byband | | out | F | +!! | hlw0 | tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_time_step | longwave clear sky heating rate | K s-1 | 2 | real | kind_phys | inout | T | +!! | hlwb | lw_heating_rate_spectral | longwave total sky heating rate (spectral) | K s-1 | 3 | real | kind_phys | inout | T | +!! | 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_lw_run(ncol, nlay, kdist_lw, p_lay, t_lay, p_lev, skt, & sfc_emiss, gas_concentrations, optical_props_clds, optical_props_aerosol,& - fluxLW_allsky, fluxLW_clrsky, errmsg, errflg) + lslwr, fluxLW_allsky, fluxLW_clrsky, hlw0, hlwb, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -56,21 +701,53 @@ subroutine rrtmgp_lw_run(ncol, nlay, kdist_lw, p_lay, t_lay, p_lev, skt, & real(kind_phys), dimension(kdist_lw%get_nband(),ncol) :: & sfc_emiss ! Surface emissivity (1) type(ty_optical_props_1scl),intent(in) :: & - optical_props_clds, & - optical_props_aerosol + optical_props_clds, & ! RRTMGP DDT: cloud radiative properties + optical_props_aerosol ! RRTMGP DDT: aerosol radiative properties type(ty_gas_concs),intent(in) :: & - gas_concentrations - type(ty_fluxes_byband),intent(out) :: & - fluxLW_allsky, & ! All-sky flux (W/m2) - fluxLW_clrsky ! Clear-sky flux (W/m2) + gas_concentrations ! RRTMGP DDT: trace gas concentrations (vmr) + logical, intent(in) :: & + lslwr ! Flag to calculate LW irradiances ! Outputs character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + + type(ty_fluxes_byband),intent(out) :: & + fluxLW_allsky, & ! All-sky flux (W/m2) + fluxLW_clrsky ! Clear-sky flux (W/m2) + ! Outputs (optional) + real(kind_phys), dimension(ncol,nlay,kdist_lw%get_nband()), optional, intent(inout) :: & + hlwb ! All-sky heating rate, by band (K/sec) + real(kind_phys), dimension(ncol,nlay), optional, intent(inout) :: & + hlw0 ! Clear-sky heating rate (K/sec) + + ! Local variables + real(kind_phys), dimension(ncol,nlay+1),target :: & + flux_up_allsky, flux_up_clrsky, flux_dn_allsky, flux_dn_clrsky + real(kind_phys), dimension(ncol,nlay+1,kdist_lw%get_nband()),target :: & + fluxBB_up_allsky, fluxBB_dn_allsky + logical :: l_ClrSky_HR, l_AllSky_HR_byband + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + if (.not. lslwr) return + + ! Are any optional outputs requested? Need to know now to compute correct fluxes. + l_ClrSky_HR = present(hlw0) + l_AllSky_HR_byband = present(hlwb) + + ! Initialize RRTMGP DDT containing 2D(3D) fluxes + fluxLW_allsky%flux_up => flux_up_allsky + fluxLW_allsky%flux_dn => flux_dn_allsky + fluxLW_clrsky%flux_up => flux_up_clrsky + fluxLW_clrsky%flux_dn => flux_dn_clrsky + ! Only calculate fluxes by-band, only when heating-rate profiles by band are requested. + if (l_AllSky_HR_byband) then + fluxLW_allsky%bnd_flux_up => fluxBB_up_allsky + fluxLW_allsky%bnd_flux_dn => fluxBB_dn_allsky + endif ! Call RRTMGP LW scheme call check_error_msg(rte_lw( & @@ -94,7 +771,7 @@ subroutine check_error_msg(error_msg) character(len=*), intent(in) :: error_msg if(error_msg /= "") then - print*,"ERROR(rrtmgp_sw_main.F90): " + print*,"ERROR(rrtmgp_lw.F90): " print*,trim(error_msg) return end if diff --git a/physics/rrtmgp_lw_post.F90 b/physics/rrtmgp_lw_post.F90 deleted file mode 100644 index 797c28de5..000000000 --- a/physics/rrtmgp_lw_post.F90 +++ /dev/null @@ -1,174 +0,0 @@ -! ########################################################################################### -! ########################################################################################### -module rrtmgp_lw_post - use machine, only: kind_phys - 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, only: check_error_msg - use module_radlw_parameters, only: topflw_type, sfcflw_type, proflw_type - - implicit none - - ! Logical flags for optional output fields in rrtmgp_lw_post_run(), default=.false. - logical :: & - l_AllSky_HR_byband = .false., & ! 2D [ncol,nlay] all-sky heating rates, in each band [ncol,nlay,nBandsLW]? - l_ClrSky_HR = .false., & ! 2D [ncol,nlay] clear-sky heating rate? - l_fluxes2D = .false. ! 2D [ncol,nlay] radiative fluxes? *Note* fluxes is a DDT w/ 4 fields. - - public rrtmgp_lw_post_init, rrtmgp_lw_post_run, rrtmgp_lw_post_finalize -contains - - subroutine rrtmgp_lw_post_init() - end subroutine rrtmgp_lw_post_init - - ! ######################################################################################### - ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_post_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |-----------------------|-----------------------------------------------------------------------------------------------|--------------------------------------------------------------------|-------|------|-----------------------|-----------|--------|----------| -!! | ncol | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | -!! | nlay | adjusted_vertical_layer_dimension_for_radiation | number of vertical layers for radiation | count | 0 | integer | | in | F | -!! | p_lev | air_pressure_at_interface_for_radiation_in_hPa | air pressure level | hPa | 2 | real | kind_phys | in | F | -!! | fluxLW_allsky | lw_flux_profiles_byband_allsky | Fortran DDT containing RRTMGP 3D fluxes | DDT | 0 | ty_fluxes_byband | | in | F | -!! | fluxLW_clrsky | lw_flux_profiles_byband_clrsky | Fortran DDT containing RRTMGP 3D fluxes | DDT | 0 | ty_fluxes_byband | | in | F | -!! | kdist_lw | K_distribution_file_for_RRTMGP_LW_scheme | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | 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 | -!! | 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_fluxes_top_atmosphere | longwave total sky fluxes at the top of the atm | W m-2 | 1 | topflw_type | | inout | F | -!! | sfcflx | lw_fluxes_sfc | longwave total sky fluxes at the Earth surface | W m-2 | 1 | sfcflw_type | | inout | F | -!! | hlw0 | tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_time_step | longwave clear sky heating rate | K s-1 | 2 | real | kind_phys | inout | T | -!! | hlwb | lw_heating_rate_spectral | longwave total sky heating rate (spectral) | K s-1 | 3 | real | kind_phys | inout | T | -!! | flxprf | lw_fluxes | lw fluxes total sky / csk and up / down at levels | W m-2 | 2 | proflw_type | | inout | T | -!! - subroutine rrtmgp_lw_post_run(ncol, nlay, p_lev, kdist_lw, fluxLW_allsky, fluxLW_clrsky, & - hlwc, topflx, sfcflx, hlw0, hlwb, flxprf, errmsg, errflg) - - ! Inputs - integer, intent(in) :: & - ncol, & ! Number of horizontal gridpoints - nlay ! Number of vertical layers - real(kind_phys), dimension(ncol,nlay+1), intent(in) :: & - p_lev ! Pressure @ model layer-interfaces (hPa) - type(ty_gas_optics_rrtmgp),intent(in) :: & - kdist_lw ! DDT containing LW spectral information - type(ty_fluxes_byband),intent(in) :: & - fluxLW_allsky, & ! All-sky flux (W/m2) - fluxLW_clrsky ! Clear-sky flux (W/m2) - - ! Outputs - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys),dimension(ncol,nlay),intent(inout) :: & - hlwc ! All-sky heating-rate (K/sec) - type(topflw_type), dimension(ncol), intent(inout) :: & - topflx ! radiation fluxes at top, components: - ! upfxc - total sky upward flux at top (w/m2) - ! upfx0 - clear sky upward flux at top (w/m2) - type(sfcflw_type), dimension(ncol), intent(inout) :: & - sfcflx ! radiation fluxes at sfc, components: - ! upfxc - total sky upward flux at sfc (w/m2) - ! upfx0 - clear sky upward flux at sfc (w/m2) - ! dnfxc - total sky downward flux at sfc (w/m2) - ! dnfx0 - clear sky downward flux at sfc (w/m2) - - ! Outputs (optional) - real(kind_phys), dimension(ncol,nlay,kdist_lw%get_nband()), optional, intent(inout) :: & - hlwb ! All-sky heating rate, by band (K/sec) - real(kind_phys), dimension(ncol,nlay), optional, intent(inout) :: & - hlw0 ! Clear-sky heating rate (K/sec) - type(proflw_type), dimension(ncol,nlay+1), optional, intent(inout) :: & - flxprf ! 2D radiative fluxes, components: - ! upfxc - total sky upward flux (W/m2) - ! dnfxc - total sky dnward flux (W/m2) - ! upfx0 - clear sky upward flux (W/m2) - ! dnfx0 - clear sky dnward flux (W/m2) - - ! Local variables - integer :: iBand, iTOA, iSFC - logical :: top_at_1 - real(kind_phys), dimension(ncol,nlay) :: thetaTendClrSky, thetaTendAllSky - real(kind_phys), dimension(ncol,nlay,kdist_lw%get_nband()) :: thetaTendByBandAllSky - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! What is vertical ordering? - top_at_1 = (p_lev(1,1) .lt. p_lev(1,nlay)) - if (top_at_1) then - iSFC = nlay+1 - iTOA = 1 - else - iSFC = 1 - iTOA = nlay+1 - endif - - ! Are any optional outputs requested? - l_ClrSky_HR = present(hlw0) - l_AllSky_HR_byband = present(hlwb) - l_fluxes2D = present(flxprf) - - ! ####################################################################################### - ! Compute heating rates - ! ####################################################################################### - if (l_ClrSky_HR) then - call check_error_msg(compute_heating_rate( & - fluxLW_clrsky%flux_up, & - fluxLW_clrsky%flux_dn, & - p_lev(1:ncol,1:nlay+1), & - thetaTendClrSky)) - endif - if (l_AllSky_HR_byband) then - do iBand=1,kdist_lw%get_nband() - call check_error_msg(compute_heating_rate( & - fluxLW_allsky%bnd_flux_up(:,:,iBand), & - fluxLW_allsky%bnd_flux_dn(:,:,iBand), & - p_lev(1:ncol,1:nlay+1), & - thetaTendByBandAllSky(:,:,iBand))) - enddo - else - call check_error_msg(compute_heating_rate( & - fluxLW_allsky%flux_up, & - fluxLW_allsky%flux_dn, & - p_lev(1:ncol,1:nlay+1), & - thetaTendAllSky)) - endif - - ! ####################################################################################### - ! Copy fluxes from RRTGMP types into model radiation types. - ! ####################################################################################### - ! Mandatory outputs - topflx%upfxc = fluxLW_allsky%flux_up(:,iTOA) - topflx%upfx0 = fluxLW_clrsky%flux_up(:,iTOA) - sfcflx%upfxc = fluxLW_allsky%flux_up(:,iSFC) - sfcflx%upfx0 = fluxLW_clrsky%flux_up(:,iSFC) - sfcflx%dnfxc = fluxLW_allsky%flux_dn(:,iSFC) - sfcflx%dnfx0 = fluxLW_clrsky%flux_dn(:,iSFC) - !cldtau = optical_props_cldy%tau(:,:,7) - hlwc = thetaTendAllSky - - ! Optional output - if(l_fluxes2D) then - flxprf%upfxc = fluxLW_allsky%flux_up - flxprf%dnfxc = fluxLW_allsky%flux_dn - flxprf%upfx0 = fluxLW_clrsky%flux_up - flxprf%dnfx0 = fluxLW_clrsky%flux_dn - endif - if (l_AllSky_HR_byband) then - hlwb = thetaTendByBandAllSky - endif - if (l_ClrSky_HR) then - hlw0 = thetaTendClrSky - endif - - - end subroutine rrtmgp_lw_post_run - - subroutine rrtmgp_lw_post_finalize() - end subroutine rrtmgp_lw_post_finalize - - - -end module rrtmgp_lw_post diff --git a/physics/rrtmgp_lw_pre.F90 b/physics/rrtmgp_lw_pre.F90 deleted file mode 100644 index 58a0f8df4..000000000 --- a/physics/rrtmgp_lw_pre.F90 +++ /dev/null @@ -1,746 +0,0 @@ -!>\file rrtmgp_lw_pre.f90 -!! This file contains a call to module_radiation_surface::setemis() to -!! setup surface emissivity for LW radiation. -module rrtmgp_lw_pre - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_gas_concentrations, only: ty_gas_concs - use mo_cloud_optics, only: ty_cloud_optics - use mo_rte_kind, only: wl - use rrtmgp_lw, only: check_error_msg - - ! Parameters - integer,parameter :: nGases = 6 - real(kind_phys),parameter :: epsilon=1.0e-6 - character(len=3),parameter, dimension(nGases) :: & - active_gases = (/ 'h2o', 'co2', 'o3 ', 'n2o', 'ch4', 'o2 '/) - integer :: nrghice, ipsdlw0 - -contains - -!! \section arg_table_rrtmgp_lw_pre_init 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 | -!! | mpirank | mpi_rank | current MPI rank | index | 0 | integer | | in | F | -!! | mpiroot | mpi_root | master MPI rank | index | 0 | integer | | in | F | -!! | 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 | -!! | kdist_lw | K_distribution_file_for_RRTMGP_LW_scheme | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | out | F | -!! | kdist_cldy_lw | K_distribution_file_for_cloudy_RRTMGP_LW_scheme | DDT containing spectral information for cloudy RRTMGP LW radiation scheme | DDT | 0 | ty_cloud_optics | | out | F | -!! | gas_concentrations | Gas_concentrations_for_RRTMGP_suite | DDT containing gas concentrations for RRTMGP radiation scheme | DDT | 0 | ty_gas_concs | | out | F | -!! - ! ######################################################################################### - subroutine rrtmgp_lw_pre_init(Model,mpicomm, mpirank, mpiroot, kdist_lw, kdist_cldy_lw, & - gas_concentrations, errmsg, errflg) - use netcdf - -#ifdef MPI - use mpi -#endif - - ! Inputs - type(GFS_control_type), intent(in) :: & - Model ! DDT containing model control parameters - integer,intent(in) :: & - mpicomm, & ! MPI communicator - mpirank, & ! Current MPI rank - mpiroot ! Master MPI rank - type(ty_gas_optics_rrtmgp),intent(out) :: & - kdist_lw - type(ty_cloud_optics),intent(out) :: & - kdist_cldy_lw - type(ty_gas_concs),intent(out) :: & - gas_concentrations - ! Outputs - character(len=*), intent(out) :: & - errmsg ! Error message - integer, intent(out) :: & - errflg ! Error code - - ! Variables that will be passed to gas_optics%load() - integer, dimension(:), allocatable :: & - kminor_start_lower, & ! used by RRTGMP gas optics - kminor_start_upper ! used by RRTGMP gas optics - integer, dimension(:,:), allocatable :: & - band2gpt, & ! used by RRTGMP gas optics - minor_limits_gpt_lower, & ! used by RRTGMP gas optics - minor_limits_gpt_upper ! used by RRTGMP gas optics - integer, dimension(:,:,:), allocatable :: & - key_species ! used by RRTGMP gas optics - real(kind_phys) :: & - press_ref_trop, & ! used by RRTGMP gas optics - temp_ref_p, & ! used by RRTGMP gas optics - temp_ref_t, & ! used by RRTGMP gas optics - radliq_lwr, & ! used by RRTGMP cloud optics - radliq_upr, & ! used by RRTGMP cloud optics - radliq_fac, & ! used by RRTGMP cloud optics - radice_lwr, & ! used by RRTGMP cloud optics - radice_upr, & ! used by RRTGMP cloud optics - radice_fac ! used by RRTGMP cloud optics - real(kind_phys), dimension(:), allocatable :: & - press_ref, & ! used by RRTGMP gas optics - temp_ref, & ! used by RRTGMP gas optics - pade_sizereg_extliq, & ! used by RRTGMP cloud optics - pade_sizereg_ssaliq, & ! used by RRTGMP cloud optics - pade_sizereg_asyliq, & ! used by RRTGMP cloud optics - pade_sizereg_extice, & ! used by RRTGMP cloud optics - pade_sizereg_ssaice, & ! used by RRTGMP cloud optics - pade_sizereg_asyice ! used by RRTGMP cloud optics - real(kind_phys), dimension(:,:), allocatable :: & - band_lims, & ! used by RRTGMP gas optics - totplnk, & ! used by RRTGMP gas optics - lut_extliq, & ! used by RRTGMP cloud optics - lut_ssaliq, & ! used by RRTGMP cloud optics - lut_asyliq, & ! used by RRTGMP cloud optics - band_lims_cldy ! used by RRTGMP cloud optics - - real(kind_phys), dimension(:,:,:), allocatable :: & - vmr_ref, & ! used by RRTGMP gas optics - kminor_lower, & ! used by RRTGMP gas optics - kminor_upper, & ! used by RRTGMP gas optics - rayl_lower, & ! used by RRTGMP gas optics - rayl_upper, & ! used by RRTGMP gas optics - lut_extice, & ! used by RRTGMP cloud optics - lut_ssaice, & ! used by RRTGMP cloud optics - lut_asyice, & ! used by RRTGMP cloud optics - pade_extliq, & ! used by RRTGMP cloud optics - pade_ssaliq, & ! used by RRTGMP cloud optics - pade_asyliq ! used by RRTGMP cloud optics - real(kind_phys), dimension(:,:,:,:), allocatable :: & - kmajor, & ! used by RRTGMP gas optics - planck_frac, & ! used by RRTGMP gas optics - pade_extice, & ! used by RRTGMP cloud optics - pade_ssaice, & ! used by RRTGMP cloud optics - pade_asyice ! used by RRTGMP cloud optics - character(len=32), dimension(:), allocatable :: & - gas_names, & ! used by RRTGMP gas optics - gas_minor, & ! used by RRTGMP gas optics - identifier_minor, & ! used by RRTGMP gas optics - minor_gases_lower, & ! used by RRTGMP gas optics - minor_gases_upper, & ! used by RRTGMP gas optics - scaling_gas_lower, & ! used by RRTGMP gas optics - scaling_gas_upper ! used by RRTGMP gas optics - logical(wl), dimension(:), allocatable :: & - minor_scales_with_density_lower, & ! used by RRTGMP gas optics - minor_scales_with_density_upper, & ! used by RRTGMP gas optics - scale_by_complement_lower, & ! used by RRTGMP gas optics - scale_by_complement_upper ! used by RRTGMP gas optics - - ! Dimensions (to be broadcast across all processors) - integer :: & - ntemps, & ! used by RRTGMP gas optics - npress, & ! used by RRTGMP gas optics - nabsorbers, & ! used by RRTGMP gas optics - nextrabsorbers, & ! used by RRTGMP gas optics - nminorabsorbers, & ! used by RRTGMP gas optics - nmixingfracs, & ! used by RRTGMP gas optics - nlayers, & ! used by RRTGMP gas optics - nbnds, & ! used by RRTGMP gas optics - ngpts, & ! used by RRTGMP gas optics - npairs, & ! used by RRTGMP gas optics - ninternalSourcetemps, & ! used by RRTGMP gas optics - nminor_absorber_intervals_lower, & ! used by RRTGMP gas optics - nminor_absorber_intervals_upper, & ! used by RRTGMP gas optics - ncontributors_lower, & ! used by RRTGMP gas optics - ncontributors_upper, & ! used by RRTGMP gas optics - nbandLWcldy, & ! used by RRTGMP cloud optics - nsize_liq, & ! used by RRTGMP cloud optics - nsize_ice, & ! used by RRTGMP cloud optics - nsizereg, & ! used by RRTGMP cloud optics - ncoeff_ext, & ! used by RRTGMP cloud optics - ncoeff_ssa_g, & ! used by RRTGMP cloud optics - nbound, & ! used by RRTGMP cloud optics - npairsLWcldy ! used by RRTGMP cloud optics - - ! Local variables - integer :: ncid_lw,dimID,varID,status,igpt,iGas,ij,ierr,ncid_lw_clds - integer,dimension(:),allocatable :: temp1,temp2,temp3,temp4,temp_log_array1,& - temp_log_array2, temp_log_array3, temp_log_array4 - character(len=264) :: kdist_file,kdist_cldy_file - integer,parameter :: max_strlen=256 - - ! Initialize - errmsg = '' - errflg = 0 - - ! Ensure that requested cloud overlap is reasonable. - if ( iovrlw .lt. 0 .or. iovrlw .gt. 3 ) then - print *,' *** Error in specification of cloud overlap flag', & - ' IOVRLW=',iovrlw,' in RLWINIT !!' - stop - elseif ( iovrlw .ge. 2 .and. isubclw .eq. 0 ) then - print *,' *** IOVRLW=',iovrlw,' is not available for', & - ' ISUBCLW=0 setting!!' - print *,' The program uses maximum/random overlap', & - ' instead.' - iovrlw = 1 - endif - - ! Check cloud flags for consistency. - if ((icldflg .eq. 0 .and. ilwcliq .ne. 0) .or. & - (icldflg .eq. 1 .and. ilwcliq .eq. 0)) then - print *,' *** Model cloud scheme inconsistent with LW', & - ' radiation cloud radiative property setup !!' - stop - endif - - ! How are we handling cloud-optics? - rrtmgp_lw_cld_phys = Model%rrtmgp_cld_phys - - ! Filenames are set in the gfs_physics_nml (scm/src/GFS_typedefs.F90) - kdist_file = trim(Model%rrtmgp_root)//trim(Model%kdist_lw_file_gas) - kdist_cldy_file = trim(Model%rrtmgp_root)//trim(Model%kdist_lw_file_clouds) - - ! Read dimensions for k-distribution fields (only on master processor(0)) - if (mpirank .eq. mpiroot) then - if(nf90_open(trim(kdist_file), NF90_WRITE, ncid_lw) .eq. NF90_NOERR) then - status = nf90_inq_dimid(ncid_lw, 'temperature', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=ntemps) - status = nf90_inq_dimid(ncid_lw, 'pressure', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=npress) - status = nf90_inq_dimid(ncid_lw, 'absorber', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=nabsorbers) - status = nf90_inq_dimid(ncid_lw, 'minor_absorber', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=nminorabsorbers) - status = nf90_inq_dimid(ncid_lw, 'absorber_ext', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=nextrabsorbers) - status = nf90_inq_dimid(ncid_lw, 'mixing_fraction', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=nmixingfracs) - status = nf90_inq_dimid(ncid_lw, 'atmos_layer', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=nlayers) - status = nf90_inq_dimid(ncid_lw, 'bnd', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=nbnds) - status = nf90_inq_dimid(ncid_lw, 'gpt', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=ngpts) - status = nf90_inq_dimid(ncid_lw, 'pair', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=npairs) - status = nf90_inq_dimid(ncid_lw, 'contributors_lower', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=ncontributors_lower) - status = nf90_inq_dimid(ncid_lw, 'contributors_upper', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=ncontributors_upper) - status = nf90_inq_dimid(ncid_lw, 'minor_absorber_intervals_lower', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=nminor_absorber_intervals_lower) - status = nf90_inq_dimid(ncid_lw, 'minor_absorber_intervals_upper', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=nminor_absorber_intervals_upper) - status = nf90_inq_dimid(ncid_lw, 'temperature_Planck', dimid) - status = nf90_inquire_dimension(ncid_lw, dimid, len=ninternalSourcetemps) - status = nf90_close(ncid_lw) - endif - endif - - ! Broadcast dimensions to all processors -#ifdef MPI - call MPI_BCAST(ntemps, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(npress, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nabsorbers, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nminorabsorbers, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nextraabsorbers, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nmixingfracs, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nlayers, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nbnds, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(ngpts, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(npairs, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(ncontributors_lower, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(ncontributors_upper, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nminor_absorber_intervals_lower, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nminor_absorber_intervals_upper, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(ninternalSourcetemps, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) -#endif - - !if (mpirank .eq. mpiroot) then - ! 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(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)) - - if (mpirank .eq. mpiroot) then - ! Read in fields from file - if(nf90_open(trim(kdist_file), NF90_WRITE, ncid_lw) .eq. NF90_NOERR) then - status = nf90_inq_varid(ncid_lw,'gas_names',varID) - status = nf90_get_var(ncid_lw,varID,gas_names) - ! - status = nf90_inq_varid(ncid_lw,'scaling_gas_lower',varID) - status = nf90_get_var(ncid_lw,varID,scaling_gas_lower) - ! - status = nf90_inq_varid(ncid_lw,'scaling_gas_upper',varID) - status = nf90_get_var(ncid_lw,varID,scaling_gas_upper) - ! - status = nf90_inq_varid(ncid_lw,'gas_minor',varID) - status = nf90_get_var(ncid_lw,varID,gas_minor) - ! - status = nf90_inq_varid(ncid_lw,'identifier_minor',varID) - status = nf90_get_var(ncid_lw,varID,identifier_minor) - ! - status = nf90_inq_varid(ncid_lw,'minor_gases_lower',varID) - status = nf90_get_var(ncid_lw,varID,minor_gases_lower) - ! - status = nf90_inq_varid(ncid_lw,'minor_gases_upper',varID) - status = nf90_get_var(ncid_lw,varID,minor_gases_upper) - ! - status = nf90_inq_varid(ncid_lw,'minor_limits_gpt_lower',varID) - status = nf90_get_var(ncid_lw,varID,minor_limits_gpt_lower) - ! - status = nf90_inq_varid(ncid_lw,'minor_limits_gpt_upper',varID) - status = nf90_get_var(ncid_lw,varID,minor_limits_gpt_upper) - ! - status = nf90_inq_varid(ncid_lw,'bnd_limits_gpt',varID) - status = nf90_get_var(ncid_lw,varID,band2gpt) - ! - status = nf90_inq_varid(ncid_lw,'key_species',varID) - status = nf90_get_var(ncid_lw,varID,key_species) - ! - status = nf90_inq_varid(ncid_lw,'bnd_limits_wavenumber',varID) - status = nf90_get_var(ncid_lw,varID,band_lims) - ! - status = nf90_inq_varid(ncid_lw,'press_ref',varID) - status = nf90_get_var(ncid_lw,varID,press_ref) - ! - status = nf90_inq_varid(ncid_lw,'temp_ref',varID) - status = nf90_get_var(ncid_lw,varID,temp_ref) - ! - status = nf90_inq_varid(ncid_lw,'absorption_coefficient_ref_P',varID) - status = nf90_get_var(ncid_lw,varID,temp_ref_p) - ! - status = nf90_inq_varid(ncid_lw,'absorption_coefficient_ref_T',varID) - status = nf90_get_var(ncid_lw,varID,temp_ref_t) - ! - status = nf90_inq_varid(ncid_lw,'press_ref_trop',varID) - status = nf90_get_var(ncid_lw,varID,press_ref_trop) - ! - status = nf90_inq_varid(ncid_lw,'kminor_lower',varID) - status = nf90_get_var(ncid_lw,varID,kminor_lower) - ! - status = nf90_inq_varid(ncid_lw,'kminor_upper',varID) - status = nf90_get_var(ncid_lw,varID,kminor_upper) - ! - status = nf90_inq_varid(ncid_lw,'vmr_ref',varID) - status = nf90_get_var(ncid_lw,varID,vmr_ref) - ! - status = nf90_inq_varid(ncid_lw,'kmajor',varID) - status = nf90_get_var(ncid_lw,varID,kmajor) - ! - status = nf90_inq_varid(ncid_lw,'kminor_start_lower',varID) - status = nf90_get_var(ncid_lw,varID,kminor_start_lower) - ! - status = nf90_inq_varid(ncid_lw,'kminor_start_upper',varID) - status = nf90_get_var(ncid_lw,varID,kminor_start_upper) - ! - status = nf90_inq_varid(ncid_lw,'totplnk',varID) - status = nf90_get_var(ncid_lw,varID,totplnk) - ! - status = nf90_inq_varid(ncid_lw,'plank_fraction',varID) - status = nf90_get_var(ncid_lw,varID,planck_frac) - - ! Logical fields are read in as integers and then converted to logicals. - status = nf90_inq_varid(ncid_lw,'minor_scales_with_density_lower',varID) - status = nf90_get_var(ncid_lw,varID,temp1) - minor_scales_with_density_lower(:) = .false. - where(temp1 .eq. 1) minor_scales_with_density_lower(:) = .true. - ! - status = nf90_inq_varid(ncid_lw,'minor_scales_with_density_upper',varID) - status = nf90_get_var(ncid_lw,varID,temp2) - minor_scales_with_density_upper(:) = .false. - where(temp2 .eq. 1) minor_scales_with_density_upper(:) = .true. - ! - status = nf90_inq_varid(ncid_lw,'scale_by_complement_lower',varID) - status = nf90_get_var(ncid_lw,varID,temp3) - scale_by_complement_lower(:) = .false. - where(temp3 .eq. 1) scale_by_complement_lower(:) = .true. - ! - status = nf90_inq_varid(ncid_lw,'scale_by_complement_upper',varID) - status = nf90_get_var(ncid_lw,varID,temp4) - scale_by_complement_upper(:) = .false. - where(temp4 .eq. 1) scale_by_complement_upper(:) = .true. - - ! Close - status = nf90_close(ncid_lw) - endif - endif - - ! Broadcast arrays to all processors -#ifdef MPI - call MPI_BCAST(minor_limits_gpt_upper, size(minor_limits_gpt_upper), MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(minor_limits_gpt_lower, size(minor_limits_gpt_lower), MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(kminor_start_upper, size(kminor_start_upper), MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(kminor_start_lower, size(kminor_start_lower), MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(key_species, size(key_species), MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(band2gpt, size(band2gpt), MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(band_lims, size(band_lims), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(press_ref, size(press_ref), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(temp_ref, size(temp_ref), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(kminor_lower, size(kminor_lower), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(kminor_upper, size(kminor_upper), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(scaling_gas_lower, size(scaling_gas_lower), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(scaling_gas_upper, size(scaling_gas_upper), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(vmr_ref, size(vmr_ref), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(kmajor, size(kmajor), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(temp_ref_p, 1, kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(temp_ref_t, 1, kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(press_ref_trop, 1, kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(totplnk, size(totplnk), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(planck_frac, size(planck_frac), kind_phys, mpiroot, mpicomm, ierr) - ! Character arrays - do ij=1,nabsorbers - call MPI_BCAST(gas_names(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) - enddo - do ij=1,nminorabsorbers - call MPI_BCAST(gas_minor(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) - call MPI_BCAST(identifier_minor(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) - enddo - do ij=1,nminor_absorber_intervals_lower - call MPI_BCAST(minor_gases_lower(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) - enddo - do ij=1,nminor_absorber_intervals_upper - call MPI_BCAST(minor_gases_upper(ij), 32, MPI_CHAR, mpiroot, mpicomm, ierr) - enddo - ! Logical arrays (First convert to integer-array, then broadcast) - ! - allocate(temp_log_array1(nminor_absorber_intervals_lower)) - where(minor_scales_with_density_lower) - temp_log_array1 = 1 - elsewhere - temp_log_array1 = 0 - end where - call MPI_BCAST(temp_log_array1, size(temp_log_array1), MPI_INTEGER, mpiroot, mpicomm, ierr) - ! - allocate(temp_log_array2(nminor_absorber_intervals_lower)) - where(scale_by_complement_lower) - temp_log_array2 = 1 - elsewhere - temp_log_array2 = 0 - end where - call MPI_BCAST(temp_log_array2, size(temp_log_array2), MPI_INTEGER, mpiroot, mpicomm, ierr) - ! - allocate(temp_log_array3(nminor_absorber_intervals_upper)) - where(minor_scales_with_density_upper) - temp_log_array3 = 1 - elsewhere - temp_log_array3 = 0 - end where - call MPI_BCAST(temp_log_array3, size(temp_log_array3), MPI_INTEGER, mpiroot, mpicomm, ierr) - ! - allocate(temp_log_array4(nminor_absorber_intervals_upper)) - where(scale_by_complement_upper) - temp_log_array4 = 1 - elsewhere - temp_log_array4 = 0 - end where - call MPI_BCAST(temp_log_array4, size(temp_log_array4), MPI_INTEGER, mpiroot, mpicomm, ierr) -#endif - - ! Initialize gas concentrations and gas optics class with data - do iGas=1,nGases - call check_error_msg(gas_concentrations%set_vmr(active_gases(iGas), 0._kind_phys)) - enddo - call check_error_msg(kdist_lw%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)) - - ! Set initial permutation seed for McICA, initially set to number of G-points - ipsdlw0 = kdist_lw%get_ngpt() - - ! ####################################################################################### - ! If RRTMGP cloud-optics are requested, read tables and broadcast. - ! ####################################################################################### - ! Read dimensions for k-distribution fields (only on master processor(0)) - if (mpirank .eq. mpiroot) then - if(nf90_open(trim(kdist_cldy_file), NF90_WRITE, ncid_lw_clds) == NF90_NOERR) then - status = nf90_inq_dimid(ncid_lw_clds, 'nband', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nbandLWcldy) - status = nf90_inq_dimid(ncid_lw_clds, 'nrghice', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nrghice) - status = nf90_inq_dimid(ncid_lw_clds, 'nsize_liq', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nsize_liq) - status = nf90_inq_dimid(ncid_lw_clds, 'nsize_ice', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nsize_ice) - status = nf90_inq_dimid(ncid_lw_clds, 'nsizereg', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nsizereg) - status = nf90_inq_dimid(ncid_lw_clds, 'ncoeff_ext', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=ncoeff_ext) - status = nf90_inq_dimid(ncid_lw_clds, 'ncoeff_ssa_g', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=ncoeff_ssa_g) - status = nf90_inq_dimid(ncid_lw_clds, 'nbound', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=nbound) - status = nf90_inq_dimid(ncid_lw_clds, 'pair', dimid) - status = nf90_inquire_dimension(ncid_lw_clds, dimid, len=npairsLWcldy) - status = nf90_close(ncid_lw_clds) - endif - endif - - ! Broadcast dimensions to all processors -#ifdef MPI - if (rrtmgp_lw_cld_phys .eq. 1 .or. rrtmgp_lw_cld_phys .eq. 2) then - call MPI_BCAST(nbandLWcldy, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nrghice, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nsize_liq, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nsize_ice, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nsizereg, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(ncoeff_ext, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(ncoeff_ssa_g, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(nbound, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - call MPI_BCAST(npairsLWcldy, 1, MPI_INTEGER, mpiroot, mpicomm, ierr) - endif -#endif - - if (rrtmgp_lw_cld_phys .eq. 1) then - allocate(lut_extliq(nsize_liq, nBandLWcldy)) - allocate(lut_ssaliq(nsize_liq, nBandLWcldy)) - allocate(lut_asyliq(nsize_liq, nBandLWcldy)) - allocate(lut_extice(nsize_ice, nBandLWcldy, nrghice)) - allocate(lut_ssaice(nsize_ice, nBandLWcldy, nrghice)) - allocate(lut_asyice(nsize_ice, nBandLWcldy, nrghice)) - allocate(band_lims_cldy(2, nBandLWcldy)) - endif - if (rrtmgp_lw_cld_phys .eq. 2) then - allocate(pade_extliq(nbandLWcldy, nsizereg, ncoeff_ext )) - allocate(pade_ssaliq(nbandLWcldy, nsizereg, ncoeff_ssa_g)) - allocate(pade_asyliq(nbandLWcldy, nsizereg, ncoeff_ssa_g)) - allocate(pade_extice(nbandLWcldy, nsizereg, ncoeff_ext, nrghice)) - allocate(pade_ssaice(nbandLWcldy, nsizereg, ncoeff_ssa_g, nrghice)) - allocate(pade_asyice(nbandLWcldy, nsizereg, ncoeff_ssa_g, nrghice)) - 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(band_lims_cldy(2,nbandLWcldy)) - endif - - ! On master processor, allocate space, read in fields, broadcast to all processors - if (mpirank .eq. mpiroot) then - ! - if (rrtmgp_lw_cld_phys .eq. 1) then - ! - if(nf90_open(trim(kdist_cldy_file), NF90_WRITE, ncid_lw_clds) == NF90_NOERR) then - status = nf90_inq_varid(ncid_lw_clds,'radliq_lwr',varID) - status = nf90_get_var(ncid_lw_clds,varID,radliq_lwr) - status = nf90_inq_varid(ncid_lw_clds,'radliq_upr',varID) - status = nf90_get_var(ncid_lw_clds,varID,radliq_upr) - status = nf90_inq_varid(ncid_lw_clds,'radliq_fac',varID) - status = nf90_get_var(ncid_lw_clds,varID,radliq_fac) - status = nf90_inq_varid(ncid_lw_clds,'radice_lwr',varID) - status = nf90_get_var(ncid_lw_clds,varID,radice_lwr) - status = nf90_inq_varid(ncid_lw_clds,'radice_upr',varID) - status = nf90_get_var(ncid_lw_clds,varID,radice_upr) - status = nf90_inq_varid(ncid_lw_clds,'radice_fac',varID) - status = nf90_get_var(ncid_lw_clds,varID,radice_fac) - status = nf90_inq_varid(ncid_lw_clds,'lut_extliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,lut_extliq) - status = nf90_inq_varid(ncid_lw_clds,'lut_ssaliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,lut_ssaliq) - status = nf90_inq_varid(ncid_lw_clds,'lut_asyliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,lut_asyliq) - status = nf90_inq_varid(ncid_lw_clds,'lut_extice',varID) - status = nf90_get_var(ncid_lw_clds,varID,lut_extice) - status = nf90_inq_varid(ncid_lw_clds,'lut_ssaice',varID) - status = nf90_get_var(ncid_lw_clds,varID,lut_ssaice) - status = nf90_inq_varid(ncid_lw_clds,'lut_asyice',varID) - status = nf90_get_var(ncid_lw_clds,varID,lut_asyice) - status = nf90_inq_varid(ncid_lw_clds,'bnd_limits_wavenumber',varID) - status = nf90_get_var(ncid_lw_clds,varID,band_lims_cldy) - status = nf90_close(ncid_lw_clds) - endif - endif - ! - if (rrtmgp_lw_cld_phys .eq. 2) then - ! - if(nf90_open(trim(kdist_cldy_file), NF90_WRITE, ncid_lw_clds) == NF90_NOERR) then - status = nf90_inq_varid(ncid_lw_clds,'radliq_lwr',varID) - status = nf90_get_var(ncid_lw_clds,varID,radliq_lwr) - status = nf90_inq_varid(ncid_lw_clds,'radliq_upr',varID) - status = nf90_get_var(ncid_lw_clds,varID,radliq_upr) - status = nf90_inq_varid(ncid_lw_clds,'radliq_fac',varID) - status = nf90_get_var(ncid_lw_clds,varID,radliq_fac) - status = nf90_inq_varid(ncid_lw_clds,'radice_lwr',varID) - status = nf90_get_var(ncid_lw_clds,varID,radice_lwr) - status = nf90_inq_varid(ncid_lw_clds,'radice_upr',varID) - status = nf90_get_var(ncid_lw_clds,varID,radice_upr) - status = nf90_inq_varid(ncid_lw_clds,'radice_fac',varID) - status = nf90_get_var(ncid_lw_clds,varID,radice_fac) - status = nf90_inq_varid(ncid_lw_clds,'pade_extliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_extliq) - status = nf90_inq_varid(ncid_lw_clds,'pade_ssaliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_ssaliq) - status = nf90_inq_varid(ncid_lw_clds,'pade_asyliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_asyliq) - status = nf90_inq_varid(ncid_lw_clds,'pade_extice',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_extice) - status = nf90_inq_varid(ncid_lw_clds,'pade_ssaice',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_ssaice) - status = nf90_inq_varid(ncid_lw_clds,'pade_asyice',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_asyice) - status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_extliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_extliq) - status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_ssaliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_ssaliq) - status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_asyliq',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_asyliq) - status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_extice',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_extice) - status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_ssaice',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_ssaice) - status = nf90_inq_varid(ncid_lw_clds,'pade_sizreg_asyice',varID) - status = nf90_get_var(ncid_lw_clds,varID,pade_sizereg_asyice) - status = nf90_inq_varid(ncid_lw_clds,'bnd_limits_wavenumber',varID) - status = nf90_get_var(ncid_lw_clds,varID,band_lims_cldy) - status = nf90_close(ncid_lw_clds) - endif - endif - endif - - ! Broadcast arrays to all processors -#ifdef MPI - if (rrtmgp_lw_cld_phys .eq. 1) then - call MPI_BCAST(radliq_lwr, size(radliq_lwr), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(radliq_upr, size(radliq_upr), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(radliq_fac, size(radliq_fac), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(radice_lwr, size(radice_lwr), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(radice_upr, size(radice_upr), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(radice_fac, size(radice_fac), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(lut_extliq, size(lut_extliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(lut_ssaliq, size(lut_ssaliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(lut_asyliq, size(lut_asyliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(lut_extice, size(lut_extice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(lut_ssaice, size(lut_ssaice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(lut_asyice, size(lut_asyice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(band_lims_cldy), size(band_lims_cldy), kind_phys, mpiroot, mpicomm, ierr) - endif - if (rrtmgp_lw_cld_phys .eq. 2) then - call MPI_BCAST(pade_extliq, size(pade_extliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_ssaliq, size(pade_ssaliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_asyliq, size(pade_asyliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_extice, size(pade_extice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_ssaice, size(pade_ssaice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_asyice, size(pade_asyice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_sizereg_extliq), size(pade_sizereg_extliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_sizereg_ssaliq), size(pade_sizereg_ssaliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_sizereg_asyliq), size(pade_sizereg_asyliq), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_sizereg_extice), size(pade_sizereg_extice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_sizereg_ssaice), size(pade_sizereg_ssaice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(pade_sizereg_asyice), size(pade_sizereg_asyice), kind_phys, mpiroot, mpicomm, ierr) - call MPI_BCAST(band_lims_cldy), size(band_lims_cldy), kind_phys, mpiroot, mpicomm, ierr) - endif -#endif - - ! Load tables data for RRTGMP cloud-optics - if (rrtmgp_lw_cld_phys .eq. 1) then - call check_error_msg(kdist_cldy_lw%set_ice_roughness(nrghice)) - call check_error_msg(kdist_cldy_lw%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 (rrtmgp_lw_cld_phys .eq. 2) then - call check_error_msg(kdist_cldy_lw%set_ice_roughness(nrghice)) - call check_error_msg(kdist_cldy_lw%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, & - pade_sizereg_extice, pade_sizereg_ssaice, pade_sizereg_asyice)) - endif - - end subroutine rrtmgp_lw_pre_init - -!> \section arg_table_rrtmgp_lw_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 | -!! | 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 | -!! | 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 | -!! | kdist_lw | K_distribution_file_for_RRTMGP_LW_scheme | DDT containing spectral information for RRTMGP LW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | in | F | -!! | sfc_emiss_byband | surface_longwave_emissivity_in_each_band | surface lw emissivity in fraction in each LW band | frac | 2 | real | kind_phys | inout | F | -!! - subroutine rrtmgp_lw_pre_run (Model, Grid, Sfcprop, Radtend, im, tsfg, tsfa, kdist_lw, sfc_emiss_byband, 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: setemis - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - - 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 - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg - type(ty_gas_optics_rrtmgp),intent(in) :: & - kdist_lw ! DDT containing LW spectral information - real(kind_phys),dimension(kdist_lw%get_nband(),im),intent(inout) :: sfc_emiss_byband - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer :: ij - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - print*,'In RRTMGP_lW_PRE_RUN(): top',shape(sfc_emiss_byband),im - print*,'In RRTMGP_lW_PRE_RUN(): top',shape(Radtend%semis) - if (Model%lslwr) then -!> - Call module_radiation_surface::setemis(),to setup surface -!! emissivity for LW radiation. - call setemis (Grid%xlon, Grid%xlat, Sfcprop%slmsk, & ! --- inputs - Sfcprop%snowd, Sfcprop%sncovr, Sfcprop%zorl, & - tsfg, tsfa, Sfcprop%hprim, IM, & - Radtend%semis) ! --- outputs - do ij=1,kdist_lw%get_nband() - print*,ij - sfc_emiss_byband(ij,1:im) = Radtend%semis(1:im) - enddo - endif - print*,'In RRTMGP_lW_PRE_RUN(): bottom' - - end subroutine rrtmgp_lw_pre_run - -!> \section arg_table_rrtmgp_lw_pre_finalize Argument Table -!! - subroutine rrtmgp_lw_pre_finalize () - end subroutine rrtmgp_lw_pre_finalize -!! @} - end module rrtmgp_lw_pre diff --git a/physics/rrtmgp_sw.F90 b/physics/rrtmgp_sw.F90 index 9b1d66a42..b1eec1fe1 100644 --- a/physics/rrtmgp_sw.F90 +++ b/physics/rrtmgp_sw.F90 @@ -54,38 +54,30 @@ module rrtmgp_sw nrghice, & ! Number of ice roughness categories ipsdsw0 ! Initial seed for McICA - ! Classes used by rte+rrtmgp -! type(ty_gas_optics_rrtmgp) :: & -! kdist_sw -! type(ty_cloud_optics) :: & -! kdist_sw_cldy - type(ty_gas_concs) :: & - gas_concentrations - public rrtmgp_sw_init, rrtmgp_sw_run, rrtmgp_sw_finalize contains - ! ######################################################################################### - ! rrtmgp_sw_init - ! ######################################################################################### + !! \section arg_table_rrtmgp_sw_init 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 | -!! | mpirank | mpi_rank | current MPI rank | index | 0 | integer | | in | F | -!! | mpiroot | mpi_root | master MPI rank | index | 0 | integer | | in | F | -!! | 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 | -!! | kdist_sw | K_distribution_file_for_RRTMGP_SW_scheme | DDT containing spectral information for RRTMGP SW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | inout | F | -!! | kdist_sw_cldy | K_distribution_file_for_cloudy_RRTMGP_SW_scheme | DDT containing spectral information for cloudy RRTMGP SW radiation scheme | DDT | 0 | ty_cloud_optics | | inout | F | +!! | 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 | +!! | mpirank | mpi_rank | current MPI rank | index | 0 | integer | | in | F | +!! | mpiroot | mpi_root | master MPI rank | index | 0 | integer | | in | F | +!! | 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 | +!! | kdist_sw | K_distribution_file_for_RRTMGP_SW_scheme | DDT containing spectral information for RRTMGP SW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | inout | F | +!! | kdist_cldy_sw | K_distribution_file_for_cloudy_RRTMGP_SW_scheme | DDT containing spectral information for cloudy RRTMGP SW radiation scheme | DDT | 0 | ty_cloud_optics | | inout | F | !! ! ######################################################################################### - subroutine rrtmgp_sw_init(Model,mpicomm, mpirank, mpiroot, kdist_sw, kdist_sw_cldy, & + subroutine rrtmgp_sw_init(Model,mpicomm, mpirank, mpiroot, kdist_sw, kdist_cldy_sw, & errmsg, errflg) use netcdf + #ifdef MPI use mpi #endif + ! Inputs type(GFS_control_type), intent(in) :: & Model ! DDT containing model control parameters @@ -93,12 +85,11 @@ subroutine rrtmgp_sw_init(Model,mpicomm, mpirank, mpiroot, kdist_sw, kdist_sw_cl mpicomm, & ! MPI communicator mpirank, & ! Current MPI rank mpiroot ! Master MPI rank - type(ty_gas_optics_rrtmgp) :: & - kdist_sw ! RRTMGP DDT containing SW spectral information - type(ty_cloud_optics) :: & - kdist_sw_cldy -! type(ty_gas_concs_type),intent(inout) :: & -! gas_concentrations + type(ty_gas_optics_rrtmgp),intent(inout) :: & + kdist_sw + type(ty_cloud_optics),intent(inout) :: & + kdist_cldy_sw + ! Outputs character(len=*), intent(out) :: & errmsg ! Error message @@ -107,6 +98,8 @@ subroutine rrtmgp_sw_init(Model,mpicomm, mpirank, mpiroot, kdist_sw, kdist_sw_cl ! Fields from the K-distribution files ! Variables that will be passed to gas_optics%load() + type(ty_gas_concs) :: & + gas_concentrations integer, dimension(:), allocatable :: & kminor_start_lower_sw, & ! used by RRTGMP gas optics kminor_start_upper_sw ! used by RRTGMP gas optics @@ -505,7 +498,7 @@ subroutine rrtmgp_sw_init(Model,mpicomm, mpirank, mpiroot, kdist_sw, kdist_sw_cl ! Initialize gas concentrations and gas optics class with data do iGas=1,nGases call check_error_msg(gas_concentrations%set_vmr(active_gases(iGas), 0._kind_phys)) - enddo + enddo call check_error_msg(kdist_sw%load(gas_concentrations, gas_names_sw, key_species_sw, band2gpt_sw, & band_lims_sw, press_ref_sw, press_ref_trop_sw, temp_ref_sw, temp_ref_p_sw, temp_ref_t_sw, & vmr_ref_sw, kmajor_sw, kminor_lower_sw, kminor_upper_sw, gas_minor_sw,identifier_minor_sw, & @@ -709,15 +702,15 @@ subroutine rrtmgp_sw_init(Model,mpicomm, mpirank, mpiroot, kdist_sw, kdist_sw_cl ! Load tables data for RRTGMP cloud-optics if (rrtmgp_sw_cld_phys .eq. 1) then - call check_error_msg(kdist_sw_cldy%set_ice_roughness(nrghice)) - call check_error_msg(kdist_sw_cldy%load(band_lims_cldy_sw, radliq_lwr_sw, & + call check_error_msg(kdist_cldy_sw%set_ice_roughness(nrghice)) + call check_error_msg(kdist_cldy_sw%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 (rrtmgp_sw_cld_phys .eq. 2) then - call check_error_msg(kdist_sw_cldy%set_ice_roughness(nrghice)) - call check_error_msg(kdist_sw_cldy%load(band_lims_cldy_sw, pade_extliq_sw, & + call check_error_msg(kdist_cldy_sw%set_ice_roughness(nrghice)) + call check_error_msg(kdist_cldy_sw%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, pade_sizereg_asyliq_sw, & pade_sizereg_extice_sw, pade_sizereg_ssaice_sw, pade_sizereg_asyice_sw)) @@ -787,13 +780,13 @@ end subroutine rrtmgp_sw_init !! | 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 | !! | kdist_sw | K_distribution_file_for_RRTMGP_SW_scheme | DDT containing spectral information for RRTMGP SW radiation scheme | DDT | 0 | ty_gas_optics_rrtmgp | | in | F | -!! | kdist_sw_cldy | K_distribution_file_for_cloudy_RRTMGP_SW_scheme | DDT containing spectral information for cloudy RRTMGP SW radiation scheme | DDT | 0 | ty_cloud_optics | | inout | F | +!! | kdist_cldy_sw | K_distribution_file_for_cloudy_RRTMGP_SW_scheme | DDT containing spectral information for cloudy RRTMGP SW radiation scheme | DDT | 0 | ty_cloud_optics | | in | F | !! subroutine rrtmgp_sw_run(p_lay, p_lev, t_lay, t_lev, q_lay, o3_lay, vmr_co2, vmr_n2o, & ! IN vmr_ch4, vmr_o2, vmr_co, vmr_cfc11, vmr_cfc12, vmr_cfc22, vmr_ccl4, icseed, tau_aer, & ! IN ssa_aer, asy_aer, sfcalb_nir_dir, sfcalb_nir_dif, sfcalb_uvis_dir, sfcalb_uvis_dif, & ! IN dzlyr, delpin, de_lgth, cossza, solcon, nday, idxday, ncol, nlay, lprint, cldfrac, & ! IN - lsswr, kdist_sw, kdist_sw_cldy, & ! IN + lsswr, kdist_sw, kdist_cldy_sw, & ! IN hswc, topflx, sfcflx, cldtau, & ! OUT hsw0, hswB, flxprf, fdncmp, cld_lwp, cld_ref_liq, cld_iwp, cld_ref_ice, cld_rwp, & ! OUT(optional) cld_ref_rain, cld_swp, cld_ref_snow, cld_od, cld_ssa, cld_asy, & ! OUT(optional) @@ -817,9 +810,9 @@ subroutine rrtmgp_sw_run(p_lay, p_lev, t_lay, t_lev, q_lay, o3_lay, vmr_co2, vmr type(ty_gas_optics_rrtmgp),intent(in) :: & kdist_sw ! DDT containing LW spectral information type(ty_cloud_optics),intent(in) :: & - kdist_sw_cldy -! type(ty_gas_concs_type),intent(inout) :: & -! gas_concentrations + kdist_cldy_sw + !type(ty_gas_concs),intent(inout) :: & + ! gas_concentrations real(kind_phys), intent(in) :: & solcon ! Solar constant (W/m2) real(kind_phys), dimension(ncol), intent(in) :: & @@ -906,6 +899,8 @@ subroutine rrtmgp_sw_run(p_lay, p_lev, t_lay, t_lev, q_lay, o3_lay, vmr_co2, vmr ! visdf - downward uv+vis diffused flux (W/m2) ! RTE+RRTMGP classes + type(ty_gas_concs) :: & + gas_concentrations type(ty_optical_props_2str) :: & optical_props_clr, & ! Optical properties for gaseous atmosphere optical_props_aer, & ! Optical properties for aerosols @@ -1014,11 +1009,11 @@ subroutine rrtmgp_sw_run(p_lay, p_lev, t_lay, t_lev, q_lay, o3_lay, vmr_co2, vmr ! RRTMGP cloud_optics expects particle size to be in a certain range. bound here if (rrtmgp_sw_cld_phys .gt. 0) then cld_ref_ice2 = cld_ref_ice - where(cld_ref_ice2 .gt. kdist_sw_cldy%get_max_radius_ice()) cld_ref_ice2=kdist_sw_cldy%get_max_radius_ice() - where(cld_ref_ice2 .lt. kdist_sw_cldy%get_min_radius_ice()) cld_ref_ice2=kdist_sw_cldy%get_min_radius_ice() + where(cld_ref_ice2 .gt. kdist_cldy_sw%get_max_radius_ice()) cld_ref_ice2=kdist_cldy_sw%get_max_radius_ice() + where(cld_ref_ice2 .lt. kdist_cldy_sw%get_min_radius_ice()) cld_ref_ice2=kdist_cldy_sw%get_min_radius_ice() cld_ref_liq2 = cld_ref_liq - where(cld_ref_liq2 .gt. kdist_sw_cldy%get_max_radius_liq()) cld_ref_liq2=kdist_sw_cldy%get_max_radius_liq() - where(cld_ref_liq2 .lt. kdist_sw_cldy%get_min_radius_liq()) cld_ref_liq2=kdist_sw_cldy%get_min_radius_liq() + where(cld_ref_liq2 .gt. kdist_cldy_sw%get_max_radius_liq()) cld_ref_liq2=kdist_cldy_sw%get_max_radius_liq() + where(cld_ref_liq2 .lt. kdist_cldy_sw%get_min_radius_liq()) cld_ref_liq2=kdist_cldy_sw%get_min_radius_liq() endif ! Compute dry air column amount @@ -1077,17 +1072,17 @@ subroutine rrtmgp_sw_run(p_lay, p_lev, t_lay, t_lev, q_lay, o3_lay, vmr_co2, vmr if (nDay .gt. 0) then ! Allocate space for gas optical properties - ! Clear-sky - call check_error_msg(optical_props_clr%alloc_2str( nday, nlay, kdist_sw)) - call check_error_msg(optical_props_mcica%alloc_2str(nday, nlay, kdist_sw)) ! Cloud optics [nCol,nLay,nBands] - call check_error_msg(optical_props_cldy%init(optical_props_clr%get_band_lims_wavenumber())) + call check_error_msg(optical_props_cldy%init(kdist_sw%get_band_lims_wavenumber())) call check_error_msg(optical_props_cldy%alloc_2str(ncol,nlay)) ! Aerosol optics [Ccol,nLay,nBands] - call check_error_msg(optical_props_aer%init(optical_props_clr%get_band_lims_wavenumber())) + call check_error_msg(optical_props_aer%init(kdist_sw%get_band_lims_wavenumber())) call check_error_msg(optical_props_aer%alloc_2str(ncol,nlay)) + ! Cloud optics sampled [nCol,nLay,nGpts] + call check_error_msg(optical_props_mcica%alloc_2str(ncol, nlay, kdist_sw)) + - ! Initialize RRTMGP files + ! Initialize RRTMGP DDT containing 2D(3D) fluxes fluxAllSky%flux_up => flux_up_allSky fluxAllsky%flux_dn => flux_dn_allSky fluxClrSky%flux_up => flux_up_clrSky @@ -1157,7 +1152,7 @@ subroutine rrtmgp_sw_run(p_lay, p_lev, t_lay, t_lev, q_lay, o3_lay, vmr_co2, vmr ! ii) Use RRTMGP cloud-optics. if (rrtmgp_sw_cld_phys .gt. 0) then - call check_error_msg(kdist_sw_cldy%cloud_optics(nday, nlay, nBandsSW, nrghice, & + call check_error_msg(kdist_cldy_sw%cloud_optics(nday, nlay, nBandsSW, nrghice, & liqmask(idxday,1:nLay), icemask(idxday,1:nLay), cld_lwp(idxday,1:nLay), & cld_iwp(idxday,1:nLay), cld_ref_liq2(idxday,1:nLay), & cld_ref_ice2(idxday,1:nLay), optical_props_cldy)) @@ -1190,6 +1185,9 @@ subroutine rrtmgp_sw_run(p_lay, p_lev, t_lay, t_lev, q_lay, o3_lay, vmr_co2, vmr ! ####################################################################################### ! Compute fluxes ! ####################################################################################### + print*,'In rrmtgp_sw(): ' + print*,' shape(optical_props_aerosol%tau): ',shape(optical_props_aer%tau) + print*,' shape(optical_props_clds%tau): ',shape(optical_props_mcica%tau) call check_error_msg(rte_sw( & kdist_sw, & gas_concentrations, & @@ -1271,7 +1269,7 @@ subroutine check_error_msg(error_msg) character(len=*), intent(in) :: error_msg if(error_msg /= "") then - print*,"ERROR(rrtmgp_sw_main.F90): " + print*,"ERROR(rrtmgp_sw.F90): " print*,trim(error_msg) return end if