diff --git a/CMakeLists.txt b/CMakeLists.txt index b8cb88418..f16014cb7 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -80,7 +80,6 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_reorder.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels-openacc/mo_gas_optics_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90 @@ -108,8 +107,6 @@ set(SCHEMES_OPENMP_OFF ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rrtmgp/mo_ ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_sw.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_fluxes.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_lw.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels-openacc/mo_rte_solver_kernels.F90 - ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels-openacc/mo_optical_props_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/mo_rte_util_array.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90 ${LOCAL_CURRENT_SOURCE_DIR}/physics/rte-rrtmgp/rte/kernels/mo_optical_props_kernels.F90 diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index c719ae96c..47fb65d9a 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -256,9 +256,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -708,9 +708,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_GWD_generic.meta b/physics/GFS_GWD_generic.meta index f761ac5bc..78b2ee970 100644 --- a/physics/GFS_GWD_generic.meta +++ b/physics/GFS_GWD_generic.meta @@ -229,9 +229,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -383,9 +383,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 6a8d3bfcb..cb072068e 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -13,12 +13,12 @@ end subroutine GFS_MP_generic_pre_init !! \htmlinclude GFS_MP_generic_pre_run.html !! subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, & - ntrac, gt0, gq0, save_t, save_q, errmsg, errflg) + ntrac, gt0, gq0, save_t, save_q, num_dfi_radar, errmsg, errflg) ! use machine, only: kind_phys implicit none - integer, intent(in) :: im, levs, ntcw, nncl, ntrac + integer, intent(in) :: im, levs, ntcw, nncl, ntrac, num_dfi_radar logical, intent(in) :: ldiag3d, qdiag3d, do_aw real(kind=kind_phys), dimension(:,:), intent(in) :: gt0 real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0 @@ -35,12 +35,14 @@ subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, errmsg = '' errflg = 0 - if (ldiag3d .or. do_aw) then + if (ldiag3d .or. do_aw .or. num_dfi_radar>0) then do k=1,levs do i=1,im save_t(i,k) = gt0(i,k) enddo enddo + endif + if (ldiag3d .or. do_aw) then if(qdiag3d) then do n=1,ntrac do k=1,levs @@ -91,28 +93,36 @@ subroutine GFS_MP_generic_post_run( graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, pwat, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & - graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, & - dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d, lssav, & - errmsg, errflg) + graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, dfi_radar_max_intervals, & + dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d, lssav, num_dfi_radar, fh_dfi_radar, & + index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, errmsg, errflg) ! use machine, only: kind_phys implicit none - integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac + integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm integer, intent(in) :: index_of_temperature,index_of_process_mp + integer :: dfi_radar_max_intervals + real(kind=kind_phys), intent(in) :: fh_dfi_radar(:), fhour + real(kind=kind_phys), intent(in) :: radar_tten_limits(:) + integer :: ix_dfi_radar(:) + real(kind=kind_phys), dimension(:,:), intent(inout) :: gt0 + real(kind=kind_phys), intent(in) :: dtf, frain, con_g, rainmin real(kind=kind_phys), dimension(:), intent(in) :: rain1, xlat, xlon, tsfc real(kind=kind_phys), dimension(:), intent(inout) :: ice, snow, graupel, rainc real(kind=kind_phys), dimension(:), intent(in) :: rain0, ice0, snow0, graupel0 real(kind=kind_phys), dimension(:,:), intent(in) :: rann - real(kind=kind_phys), dimension(:,:), intent(in) :: gt0, prsl, save_t, del + real(kind=kind_phys), dimension(:,:), intent(in) :: prsl, save_t, del real(kind=kind_phys), dimension(:,:), intent(in) :: prsi, phii real(kind=kind_phys), dimension(:,:,:), intent(in) :: gq0, save_q + real(kind=kind_phys), dimension(:,:,:), intent(in) :: dfi_radar_tten + real(kind=kind_phys), dimension(:), intent(in ) :: sr real(kind=kind_phys), dimension(:), intent(inout) :: rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, & srflag, cnvprcp, totprcp, totice, totsnw, totgrp, cnvprcpb, & @@ -150,10 +160,10 @@ subroutine GFS_MP_generic_post_run( real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys ! *DH - integer :: i, k, ic, itrac, idtend + integer :: i, k, ic, itrac, idtend, itime, idtend_radar, idtend_mp real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2 + real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2, ttend real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 ! Initialize CCPP error handling variables @@ -244,6 +254,52 @@ subroutine GFS_MP_generic_post_run( endif + do itime=1,num_dfi_radar + if(ix_dfi_radar(itime)<1) cycle + if(fhour=fh_dfi_radar(itime+1)) cycle + exit + enddo + if_radar: if(itime<=num_dfi_radar) then + radar_k: do k=3,levs-2 ! Avoid model top and bottom in case DA forgets to + radar_i: do i=1,im + ttend = dfi_radar_tten(i,k,itime) + if_active: if (ttend>-19) then + ttend = max(ttend,radar_tten_limits(1)) + ttend = min(ttend,radar_tten_limits(2)) + + ! add radar temp tendency + ! there is radar coverage + gt0(i,k) = save_t(i,k) + ttend*dtp + end if if_active + end do radar_i + end do radar_k + if(ldiag3d) then + idtend_radar = dtidx(index_of_temperature,index_of_process_dfi_radar) + idtend_mp = dtidx(index_of_temperature,index_of_process_mp) + if(idtend_radar>0 .or. idtend_mp>0) then + if(idtend_mp>0) then + dtend(:,1:2,idtend_mp) = dtend(:,1:2,idtend_mp) + (gt0(:,1:2)-save_t(:,1:2))*frain + endif + do k=3,levs-2 ! Avoid model top and bottom in case DA forgets to + do i=1,im + ttend = dfi_radar_tten(i,k,itime) + if (ttend>-19) then + if(idtend_radar>0) then + dtend(i,k,idtend_radar) = dtend(i,k,idtend_radar) + (gt0(i,k)-save_t(i,k)) * frain + endif + else if(idtend_mp>0) then + dtend(i,k,idtend_mp) = dtend(i,k,idtend_mp) + (gt0(i,k)-save_t(i,k)) * frain + endif + enddo + enddo + if(idtend_mp>0) then + dtend(:,levs-1:levs,idtend_mp) = dtend(:,levs-1:levs,idtend_mp) + (gt0(:,levs-1:levs)-save_t(:,levs-1:levs))*frain + endif + endif + endif + endif if_radar + t850(1:im) = gt0(1:im,1) do k = 1, levs-1 diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index d14c11baf..1526948e4 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -95,6 +95,13 @@ type = real kind = kind_phys intent = inout +[num_dfi_radar] + standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -104,9 +111,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -727,6 +734,66 @@ type = real kind = kind_phys intent = in +[dfi_radar_max_intervals] + standard_name = maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = maximum allowed number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[num_dfi_radar] + standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[fh_dfi_radar] + standard_name = forecast_lead_times_bounding_radar_derived_temperature_or_convection_suppression_intervals + long_name = forecast lead times bounding radar derived temperature or convection suppression intervals + units = h + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals_plus_one) + type = real + kind = kind_phys + intent = in +[ix_dfi_radar] + standard_name = indices_with_radar_derived_temperature_or_convection_suppression_data + long_name = indices with radar derived temperature or convection suppression data + units = index + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = integer + intent = in +[dfi_radar_tten] + standard_name = radar_derived_microphysics_temperature_tendency + long_name = radar-derived microphysics temperature tendency + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = real + kind = kind_phys + intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[radar_tten_limits] + standard_name = allowed_bounds_of_radar_prescribed_tendencies + long_name = allowed bounds of prescribed microphysics temperature tendencies + units = K s-1 + dimensions = (2) + type = real + kind = kind_phys + intent = in +[index_of_process_dfi_radar] + standard_name = index_of_radar_derived_microphysics_temperature_forcing_in_cumulative_change_index + long_name = index of radar-derived microphysics temperature forcing in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in [dtend] standard_name = cumulative_change_of_state_variables long_name = diagnostic tendencies for state variables @@ -786,9 +853,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 3dcf81043..27c659c2c 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -368,9 +368,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1238,9 +1238,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index 90dc72d42..5cbda127c 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -249,9 +249,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -672,9 +672,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index 986548b5a..aab5387d0 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -137,9 +137,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 308376b10..8e6d5e781 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -390,7 +390,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, #ifdef MPI use mpi #endif -#ifdef OPENMP +#ifdef _OPENMP use omp_lib #endif use GFS_typedefs, only: GFS_control_type, GFS_statein_type, & @@ -437,7 +437,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, mpisize = 1 mpicomm = 0 #endif -#ifdef OPENMP +#ifdef _OPENMP omprank = OMP_GET_THREAD_NUM() ompsize = nthreads #else @@ -445,7 +445,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, ompsize = 1 #endif -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif #ifdef MPI @@ -932,7 +932,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_tau', Grid%jindx2_tau ) endif end if -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif end do @@ -941,7 +941,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, #endif end do -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif #ifdef MPI @@ -1046,7 +1046,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup #ifdef MPI use mpi #endif -#ifdef OPENMP +#ifdef _OPENMP use omp_lib #endif use machine, only: kind_phys @@ -1095,7 +1095,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup mpisize = 1 mpicomm = 0 #endif -#ifdef OPENMP +#ifdef _OPENMP omprank = OMP_GET_THREAD_NUM() ompsize = nthreads #else @@ -1103,7 +1103,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup ompsize = 1 #endif -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif #ifdef MPI @@ -1453,7 +1453,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%precip_overlap_param', Interstitial%precip_overlap_param ) end if end if -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif end do @@ -1462,7 +1462,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup #endif end do -#ifdef OPENMP +#ifdef _OPENMP !$OMP BARRIER #endif #ifdef MPI diff --git a/physics/GFS_debug.meta b/physics/GFS_debug.meta index 2071a18c1..23175ce0f 100644 --- a/physics/GFS_debug.meta +++ b/physics/GFS_debug.meta @@ -37,9 +37,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -78,9 +78,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -189,9 +189,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -236,9 +236,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -277,9 +277,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -388,9 +388,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -428,9 +428,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -680,9 +680,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -764,9 +764,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -842,9 +842,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -927,9 +927,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index d6155e6b1..d476c9211 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -7,7 +7,7 @@ !> @{ module GFS_phys_time_vary -#ifdef OPENMP +#ifdef _OPENMP use omp_lib #endif @@ -79,14 +79,14 @@ subroutine GFS_phys_time_vary_init ( albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & - slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, flag_restart, nthrds, & + slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, & errmsg, errflg) implicit none ! Interface variables integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny - logical, intent(in) :: h2o_phys, iaerclm, flag_restart + logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhour real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) @@ -355,7 +355,7 @@ subroutine GFS_phys_time_vary_init ( !$OMP section !--- if sncovr does not exist in the restart, need to create it if (all(sncovr < zero)) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' !--- compute sncovr from existing variables !--- code taken directly from read_fix.f sncovr(:) = zero @@ -376,7 +376,7 @@ subroutine GFS_phys_time_vary_init ( !--- For RUC LSM: create sncovr_ice from sncovr if (lsm == lsm_ruc) then if (all(sncovr_ice < zero)) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' sncovr_ice(:) = sncovr(:) endif endif @@ -394,9 +394,9 @@ subroutine GFS_phys_time_vary_init ( !--- For Noah MP or RUC LSMs: initialize four components of albedo for !--- land and ice - not for restart runs - lsm_init: if (.not.flag_restart) then + lsm_init: if (lsm_cold_start) then if (lsm == lsm_noahmp .or. lsm == lsm_ruc) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' do ix=1,im albdvis_lnd(ix) = 0.2_kind_phys albdnir_lnd(ix) = 0.2_kind_phys diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 0af6cda3c..b4ede6f5a 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -874,9 +874,9 @@ type = real kind = kind_phys intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart +[lsm_cold_start] + standard_name = do_lsm_cold_start + long_name = flag to signify LSM is cold-started units = flag dimensions = () type = logical @@ -897,9 +897,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -917,9 +917,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1855,9 +1855,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1875,9 +1875,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index b06e46cdc..c70e3232a 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -6,7 +6,7 @@ !! aerosol, IN&CCN and surface properties updates. !> @{ module GFS_phys_time_vary - + use machine, only : kind_phys use mersenne_twister, only: random_setseed, random_number @@ -17,7 +17,7 @@ module GFS_phys_time_vary use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol - use aerclm_def, only : aerin, aer_pres, ntrcaer, ntrcaerm + use aerclm_def, only : aerin, aer_pres, ntrcaer, ntrcaerm, iamin, iamax, jamin, jamax use aerinterp, only : read_aerdata, setindxaer, aerinterpol, read_aerdataf use iccn_def, only : ciplin, ccnin, ci_pres @@ -62,7 +62,7 @@ module GFS_phys_time_vary !! @{ subroutine GFS_phys_time_vary_init ( & me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & - jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & + jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, & @@ -73,15 +73,16 @@ subroutine GFS_phys_time_vary_init ( albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & - slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, flag_restart, nthrds, & + slc, smc, stc, tsfcl, snowd, canopy, tg3, stype, con_t0c, lsm_cold_start, nthrds, & errmsg, errflg) implicit none ! Interface variables integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny - logical, intent(in) :: h2o_phys, iaerclm, flag_restart + logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:) + real(kind_phys), intent(in) :: fhour real(kind_phys), intent(in) :: xlat_d(:), xlon_d(:) integer, intent(inout) :: jindx1_o3(:), jindx2_o3(:), jindx1_h(:), jindx2_h(:) @@ -99,10 +100,9 @@ subroutine GFS_phys_time_vary_init ( integer, intent(in) :: isot, ivegsrc, nlunit real(kind_phys), intent(inout) :: sncovr(:), sncovr_ice(:) - integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc + integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, vtype(:) real(kind_phys), intent(in) :: min_seaice, fice(:) real(kind_phys), intent(in) :: landfrac(:) - integer, intent(in) :: vtype(:) real(kind_phys), intent(inout) :: weasd(:) ! NoahMP - only allocated when NoahMP is used @@ -168,7 +168,7 @@ subroutine GFS_phys_time_vary_init ( integer, intent(out) :: errflg ! Local variables - integer :: i, j, ix, vegtyp, iamin, iamax, jamin, jamax + integer :: i, j, ix, vegtyp real(kind_phys) :: rsnow !--- Noah MP @@ -313,7 +313,7 @@ subroutine GFS_phys_time_vary_init ( !--- if sncovr does not exist in the restart, need to create it if (all(sncovr < zero)) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: compute sncovr from weasd and soil vegetation parameters' !--- compute sncovr from existing variables !--- code taken directly from read_fix.f sncovr(:) = zero @@ -334,7 +334,7 @@ subroutine GFS_phys_time_vary_init ( !--- For RUC LSM: create sncovr_ice from sncovr if (lsm == lsm_ruc) then if (all(sncovr_ice < zero)) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: fill sncovr_ice with sncovr for RUC LSM' sncovr_ice(:) = sncovr(:) endif endif @@ -342,16 +342,15 @@ subroutine GFS_phys_time_vary_init ( if (errflg/=0) return if (iaerclm) then - call read_aerdataf (iamin, iamax, jamin, jamax, me, master, iflip, & - idate, errmsg, errflg) + call read_aerdataf (me, master, iflip, idate, fhour, errmsg, errflg) if (errflg/=0) return end if !--- For Noah MP or RUC LSMs: initialize four components of albedo for !--- land and ice - not for restart runs - lsm_init: if (.not.flag_restart) then + lsm_init: if (lsm_cold_start) then if (lsm == lsm_noahmp .or. lsm == lsm_ruc) then - if (me == master ) write(0,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' + if (me == master ) write(*,'(a)') 'GFS_phys_time_vary_init: initialize albedo for land and ice' do ix=1,im albdvis_lnd(ix) = 0.2_kind_phys albdnir_lnd(ix) = 0.2_kind_phys @@ -654,7 +653,7 @@ end subroutine GFS_phys_time_vary_init subroutine GFS_phys_time_vary_timestep_init ( & me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, & imfdeepcnv, cal_pre, random_clds, ntoz, h2o_phys, iaerclm, iccn, clstp, & - jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, & + jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & imap, jmap, prsl, seed0, rann, do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau,& @@ -664,7 +663,7 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Interface variables integer, intent(in) :: me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, & - nsswr, imfdeepcnv, iccn, ntoz + nsswr, imfdeepcnv, iccn, ntoz, iflip integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhswr, fhour logical, intent(in) :: lsswr, cal_pre, random_clds, h2o_phys, iaerclm @@ -784,7 +783,7 @@ subroutine GFS_phys_time_vary_timestep_init ( ! aerinterpol is using threading inside, don't ! move into OpenMP parallel section above call aerinterpol (me, master, nthrds, im, idate, & - fhour, jindx1_aer, jindx2_aer,& + fhour, iflip, jindx1_aer, jindx2_aer, & ddy_aer, iindx1_aer, & iindx2_aer, ddx_aer, & levs, prsl, aer_nm) diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index 566636326..21ebfb8e0 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -162,6 +162,14 @@ type = real kind = kind_phys intent = in +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in [jindx1_aer] standard_name = lower_latitude_index_of_aerosol_forcing_for_interpolation long_name = interpolation low index for prescribed aerosols in the y direction @@ -866,9 +874,9 @@ type = real kind = kind_phys intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart +[lsm_cold_start] + standard_name = do_lsm_cold_start + long_name = flag to signify LSM is cold-started units = flag dimensions = () type = logical @@ -889,9 +897,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -909,9 +917,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1144,6 +1152,13 @@ type = real kind = kind_phys intent = inout +[iflip] + standard_name = control_for_vertical_index_direction + long_name = iflip - is not the same as flipv + units = flag + dimensions = () + type = integer + intent = in [jindx1_aer] standard_name = lower_latitude_index_of_aerosol_forcing_for_interpolation long_name = interpolation low index for prescribed aerosols in the y direction @@ -1354,9 +1369,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1374,9 +1389,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/GFS_rad_time_vary.fv3.meta index 8a4938667..0e7c7c024 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/GFS_rad_time_vary.fv3.meta @@ -201,9 +201,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rad_time_vary.scm.meta b/physics/GFS_rad_time_vary.scm.meta index 8a4938667..0e7c7c024 100644 --- a/physics/GFS_rad_time_vary.scm.meta +++ b/physics/GFS_rad_time_vary.scm.meta @@ -201,9 +201,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index 268edbb54..3fd851a40 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -37,9 +37,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -485,9 +485,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmg_post.meta b/physics/GFS_rrtmg_post.meta index 80bd5c22c..0f45a2126 100644 --- a/physics/GFS_rrtmg_post.meta +++ b/physics/GFS_rrtmg_post.meta @@ -275,9 +275,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 3a3378e15..15845d4b3 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -36,7 +36,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & gasvmr_ccl4, gasvmr_cfc113, aerodp, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, & - errmsg, errflg) + spp_wts_rad, spp_rad, errmsg, errflg) use machine, only: kind_phys @@ -104,6 +104,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & uni_cld, effr_in, do_mynnedmf, & lmfshal, lmfdeep2, pert_clds + integer, intent(in) :: spp_rad + real(kind_phys), intent(in) :: spp_wts_rad(:,:) + real(kind=kind_phys), intent(in) :: fhswr, fhlwr, solhr, sup, julian, sppt_amp real(kind=kind_phys), intent(in) :: con_eps, epsm1, fvirt, rog, rocp, con_rd @@ -183,7 +186,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & integer :: i, j, k, k1, k2, lsk, lv, n, itop, ibtc, LP1, lla, llb, lya,lyb - real(kind=kind_phys) :: es, qs, delt, tem0d, gridkm, pfac + real(kind=kind_phys) :: es, qs, delt, tem0d, pfac + real(kind=kind_phys), dimension(im) :: gridkm real(kind=kind_phys), dimension(im) :: cvt1, cvb1, tem1d, tskn, xland @@ -194,9 +198,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & effrl, effri, effrr, effrs, rho, orho, plyrpa ! for Thompson MP - real(kind=kind_phys), dimension(im,lm+LTP) :: & - re_cloud, re_ice, re_snow, qv_mp, qc_mp, & - qi_mp, qs_mp, nc_mp, ni_mp, nwfa + real(kind=kind_phys), dimension(im,lm+LTP) :: & + qv_mp, qc_mp, qi_mp, qs_mp, & + nc_mp, ni_mp, nwfa real (kind=kind_phys), dimension(lm) :: cldfra1d, qv1d, & & qc1d, qi1d, qs1d, dz1d, p1d, t1d @@ -235,9 +239,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & LP1 = LM + 1 ! num of in/out levels - - gridkm = sqrt(2.0)*sqrt(dx(1)*0.001*dx(1)*0.001) - if (imp_physics == imp_physics_thompson) then max_relh = 1.5 else @@ -245,6 +246,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & endif do i = 1, IM + gridkm(i) = dx(i)*0.001 lwp_ex(i) = 0.0 iwp_ex(i) = 0.0 lwp_fc(i) = 0.0 @@ -817,30 +819,18 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! it will raise the low limit from 5 to 10, but the high limit will remain 125. call calc_effectRad (tlyr(i,:), plyr(i,:)*100., qv_mp(i,:), qc_mp(i,:), & nc_mp(i,:), qi_mp(i,:), ni_mp(i,:), qs_mp(i,:), & - re_cloud(i,:), re_ice(i,:), re_snow(i,:), 1, lm ) + effrl(i,:), effri(i,:), effrs(i,:), 1, lm ) + ! Scale Thompson's effective radii from meter to micron do k=1,lm - re_cloud(i,k) = MAX(re_qc_min, MIN(re_cloud(i,k), re_qc_max)) - re_ice(i,k) = MAX(re_qi_min, MIN(re_ice(i,k), re_qi_max)) - re_snow(i,k) = MAX(re_qs_min, MIN(re_snow(i,k), re_qs_max)) - end do - end do - ! Scale Thompson's effective radii from meter to micron - do k=1,lm - do i=1,im - re_cloud(i,k) = re_cloud(i,k)*1.e6 - re_ice(i,k) = re_ice(i,k)*1.e6 - re_snow(i,k) = re_snow(i,k)*1.e6 + effrl(i,k) = MAX(re_qc_min, MIN(effrl(i,k), re_qc_max))*1.e6 + effri(i,k) = MAX(re_qi_min, MIN(effri(i,k), re_qi_max))*1.e6 + effrs(i,k) = MAX(re_qs_min, MIN(effrs(i,k), re_qs_max))*1.e6 end do + effrl(i,lmk) = re_qc_min*1.e6 + effri(i,lmk) = re_qi_min*1.e6 + effrs(i,lmk) = re_qs_min*1.e6 end do - do k=1,lm - k1 = k + kd - do i=1,im - effrl(i,k1) = re_cloud (i,k) - effri(i,k1) = re_ice (i,k) - effrr(i,k1) = 1000. ! rrain_def=1000. - effrs(i,k1) = re_snow(i,k) - enddo - enddo + effrr(:,:) = 1000. ! rrain_def=1000. ! Update global arrays do k=1,lm k1 = k + kd @@ -861,7 +851,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ! for zhao/moorthi's (imp_phys=99) & ! ferrier's (imp_phys=5) microphysics schemes - if ((num_p3d == 4) .and. (npdf3d == 3)) then ! same as imp_physics = 98 + if ((num_p3d == 4) .and. (npdf3d == 3)) then ! same as imp_physics = imp_physics_zhao_carr_pdf do k=1,lm k1 = k + kd do i=1,im @@ -872,7 +862,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & cnvc (i,k1) = cnvc_in(i,k) enddo enddo - elseif ((npdf3d == 0) .and. (ncnvcld3d == 1)) then ! same as imp_physics=99 + elseif ((npdf3d == 0) .and. (ncnvcld3d == 1)) then ! all other microphysics with pdfcld = .false. and cnvcld = .true. do k=1,lm k1 = k + kd do i=1,im @@ -891,7 +881,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo endif - if (imp_physics == imp_physics_zhao_carr) then ccnd(1:IM,1:LMK,1) = ccnd(1:IM,1:LMK,1) + cnvw(1:IM,1:LMK) endif @@ -957,7 +946,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & call progcld5 (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,tracer1, & ! --- inputs xlat,xlon,slmsk,dz,delp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & -!mz ntsw-1,ntgl-1, & im, lmk, lmp, icloud, uni_cld, lmfshal, lmfdeep2, & cldcov(:,1:LMK),effrl_inout(:,:), & effri_inout(:,:), effrs_inout(:,:), & @@ -974,8 +962,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & im, lm, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LM), effrl_inout, & - effri_inout, effrs_inout, & + cldcov(:,1:LM), effrl, effri, effrs, & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & dzb, xlat_d, julian, yearlen, gridkm, & clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs @@ -1008,8 +995,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & im, lm, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LM), effrl_inout, & - effri_inout, effrs_inout, & + cldcov(:,1:LM), effrl, effri, effrs, & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & dzb, xlat_d, julian, yearlen, gridkm, & clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs @@ -1020,8 +1006,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ntrac-1, ntcw-1,ntiw-1,ntrw-1, & ntsw-1,ntgl-1, & im, lmk, lmp, uni_cld, lmfshal, lmfdeep2, & - cldcov(:,1:LMK), effrl_inout, & - effri_inout, effrs_inout, & + cldcov(:,1:LMK), cnvw, effrl, effri, effrs,& lwp_ex, iwp_ex, lwp_fc, iwp_fc, & dzb, xlat_d, julian, yearlen, & clouds, cldsa, mtopa ,mbota, de_lgth, alpha) ! --- outputs @@ -1078,6 +1063,24 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & enddo enddo + if ( spp_rad == 1 ) then + do k=1,lm + if (k < levs) then + do i=1,im + clouds3(i,k) = clouds3(i,k) - spp_wts_rad(i,k) * clouds3(i,k) + clouds5(i,k) = clouds5(i,k) - spp_wts_rad(i,k) * clouds5(i,k) + clouds9(i,k) = clouds9(i,k) - spp_wts_rad(i,k) * clouds9(i,k) + enddo + else + do i=1,im + clouds3(i,k) = clouds3(i,k) - spp_wts_rad(i,k) * clouds3(i,k) + clouds5(i,k) = clouds5(i,k) - spp_wts_rad(i,k) * clouds5(i,k) + clouds9(i,k) = clouds9(i,k) - spp_wts_rad(i,k) * clouds9(i,k) + enddo + endif + enddo + endif + ! mg, sfc-perts ! --- scale random patterns for surface perturbations with ! perturbation size diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index ced68890e..1eac8a571 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -532,7 +532,7 @@ [sfc_wts] standard_name = surface_stochastic_weights_from_coupled_process long_name = weights for stochastic surface physics perturbation - units = none + units = 1 dimensions = (horizontal_loop_extent,number_of_perturbed_land_surface_variables) type = real kind = kind_phys @@ -1082,6 +1082,21 @@ type = real kind = kind_phys intent = out +[spp_wts_rad] + standard_name = spp_weights_for_radiation_scheme + long_name = spp weights for radiation scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_rad] + standard_name = control_for_radiation_spp_perturbations + long_name = control for radiation spp perturbations + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1091,9 +1106,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index ecd849c48..ae0da3a5e 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -12,7 +12,7 @@ standard_name = sigma_pressure_hybrid_vertical_coordinate long_name = vertical sigma coordinate for radiation initialization units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -172,9 +172,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -268,9 +268,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -288,9 +288,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_cloud_overlap_pre.meta b/physics/GFS_rrtmgp_cloud_overlap_pre.meta index a15f1a8bd..a4620cfa2 100644 --- a/physics/GFS_rrtmgp_cloud_overlap_pre.meta +++ b/physics/GFS_rrtmgp_cloud_overlap_pre.meta @@ -234,9 +234,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.meta b/physics/GFS_rrtmgp_gfdlmp_pre.meta index 1f0a7745b..c45054613 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.meta +++ b/physics/GFS_rrtmgp_gfdlmp_pre.meta @@ -295,9 +295,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_lw_post.F90 b/physics/GFS_rrtmgp_lw_post.F90 index cccaa501c..75b705df4 100644 --- a/physics/GFS_rrtmgp_lw_post.F90 +++ b/physics/GFS_rrtmgp_lw_post.F90 @@ -1,10 +1,10 @@ -module GFS_rrtmgp_lw_post +module GFS_rrtmgp_lw_post use machine, only: kind_phys use module_radlw_parameters, only: topflw_type, sfcflw_type use mo_heating_rates, only: compute_heating_rate use radiation_tools, only: check_error_msg implicit none - + public GFS_rrtmgp_lw_post_init,GFS_rrtmgp_lw_post_run,GFS_rrtmgp_lw_post_finalize contains @@ -25,18 +25,18 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag fluxlwDOWN_clrsky, raddt, cldsa, mtopa, mbota, cld_frac, cldtaulw, fluxr, sfcdlw, & sfculw, sfcflw, tsflw, htrlw, htrlwu, topflw, htrlwc, errmsg, errflg) - ! Inputs - integer, intent(in) :: & + ! Inputs + integer, intent(in) :: & nCol, & ! Horizontal loop extent nLev, & ! Number of vertical layers iSFC, & ! Vertical index for surface level iTOA ! Vertical index for TOA level logical, intent(in) :: & lslwr, & ! Logical flags for lw radiation calls - do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? + do_lw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? real(kind_phys), intent(in) :: & - fhlwr ! Frequency for SW radiation + fhlwr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & tsfa ! Lowest model layer air temperature for radiation (K) real(kind_phys), dimension(nCol, nLev), intent(in) :: & @@ -50,23 +50,23 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag real(kind_phys), intent(in) :: & raddt ! Radiation time step real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL integer, dimension(nCol,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(nCol,nLev), intent(in) :: & cld_frac, & ! Total cloud fraction in each layer - cldtaulw ! approx 10.mu band layer cloud optical depth - + cldtaulw ! approx 10.mu band layer cloud optical depth + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - + ! Outputs (mandatory) real(kind_phys), dimension(nCol), intent(inout) :: & sfcdlw, & ! Total sky sfc downward lw flux (W/m2) sfculw, & ! Total sky sfc upward lw flux (W/m2) tsflw ! surface air temp during lw calculation (K) type(sfcflw_type), dimension(nCol), intent(inout) :: & - sfcflw ! LW radiation fluxes at sfc + sfcflw ! LW radiation fluxes at sfc real(kind_phys), dimension(nCol,nLev), intent(inout) :: & htrlw, & ! LW all-sky heating rate htrlwu ! Heating-rate updated in-between radiation calls. @@ -80,7 +80,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! Outputs (optional) real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrlwc ! Longwave clear-sky heating-rate (K/sec) - + ! Local variables integer :: i, j, k, itop, ibtc real(kind_phys) :: tem0d, tem1, tem2 @@ -92,7 +92,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag if (.not. lslwr) return ! ####################################################################################### - ! Compute LW heating-rates. + ! Compute LW heating-rates. ! ####################################################################################### ! Clear-sky heating-rate (optional) if (do_lw_clrsky_hr) then @@ -102,7 +102,7 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag p_lev, & ! IN - Pressure @ layer-interfaces (Pa) htrlwc)) ! OUT - Longwave clear-sky heating rate (K/sec) endif - + ! All-sky heating-rate (mandatory) call check_error_msg('GFS_rrtmgp_post',compute_heating_rate( & fluxlwUP_allsky, & ! IN - RRTMGP upward longwave all-sky flux profiles (W/m2) @@ -136,8 +136,8 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag ! ####################################################################################### ! Save LW diagnostics - ! - 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 + ! - 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 @@ -153,11 +153,6 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag fluxr(i,30) = fluxr(i,30) + fhlwr * fluxlwDOWN_clrsky(i,iSFC) ! clear sky sfc lw dn fluxr(i,33) = fluxr(i,33) + fhlwr * fluxlwUP_clrsky( i,iSFC) ! clear sky sfc lw up enddo - - do i=1,nCol - fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) - fluxr(i,18) = 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 @@ -166,10 +161,6 @@ subroutine GFS_rrtmgp_lw_post_run (nCol, nLev, lslwr, do_lw_clrsky_hr, save_diag tem0d = raddt * cldsa(i,j) itop = mtopa(i,j) ibtc = mbota(i,j) - fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d - fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop) - fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc) - fluxr(i,17-j) = fluxr(i,17-j) + tem0d * t_lay(i,itop) ! Add optical depth and emissivity output tem2 = 0. diff --git a/physics/GFS_rrtmgp_lw_post.meta b/physics/GFS_rrtmgp_lw_post.meta index 399f238d0..d458b25f3 100644 --- a/physics/GFS_rrtmgp_lw_post.meta +++ b/physics/GFS_rrtmgp_lw_post.meta @@ -245,9 +245,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 15ce6db1a..501dacfa1 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -40,9 +40,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -433,9 +433,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index 4043392a9..41bf63ac8 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -76,7 +76,7 @@ standard_name = sigma_pressure_hybrid_vertical_coordinate long_name = vertical sigma coordinate for radiation initialization units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -215,9 +215,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -311,9 +311,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -331,9 +331,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_sw_post.F90 b/physics/GFS_rrtmgp_sw_post.F90 index a52caac38..377afdadc 100644 --- a/physics/GFS_rrtmgp_sw_post.F90 +++ b/physics/GFS_rrtmgp_sw_post.F90 @@ -1,4 +1,4 @@ -module GFS_rrtmgp_sw_post +module GFS_rrtmgp_sw_post use machine, only: kind_phys use module_radiation_aerosols, only: NSPC1 use module_radsw_parameters, only: topfsw_type, sfcfsw_type, cmpfsw_type @@ -6,7 +6,7 @@ module GFS_rrtmgp_sw_post use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props implicit none - + public GFS_rrtmgp_sw_post_init,GFS_rrtmgp_sw_post_run,GFS_rrtmgp_sw_post_finalize contains @@ -31,25 +31,25 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirbmdi, nirdfdi, visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, & sfcdsw, htrsw, sfcfsw, topfsw, htrswc, scmpsw, errmsg, errflg) - ! Inputs - integer, intent(in) :: & - nCol, & ! Horizontal loop extent + ! Inputs + integer, intent(in) :: & + nCol, & ! Horizontal loop extent nLev, & ! Number of vertical layers nDay, & ! Number of daylit columns iSFC, & ! Vertical index for surface level iTOA ! Vertical index for TOA level integer, intent(in), dimension(nday) :: & idxday ! Index array for daytime points - logical, intent(in) :: & - lsswr, & ! Call SW radiation? - do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? - save_diag ! Output radiation diagnostics? + logical, intent(in) :: & + lsswr, & ! Call SW radiation? + do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? + save_diag ! Output radiation diagnostics? real(kind_phys), intent(in) :: & fhswr ! Frequency for SW radiation real(kind_phys), dimension(nCol), intent(in) :: & t_lay, & ! Temperature at model layer centers (K) - coszen, & ! Cosine(SZA) - coszdg ! Cosine(SZA), daytime + coszen, & ! Cosine(SZA) + coszdg ! Cosine(SZA), daytime real(kind_phys), dimension(nCol, nLev+1), intent(in) :: & p_lev ! Pressure @ model layer-interfaces (Pa) real(kind_phys), dimension(sw_gas_props%get_nband(),ncol), intent(in) :: & @@ -65,9 +65,9 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky real(kind_phys), intent(in) :: & raddt ! Radiation time step real(kind_phys), dimension(nCol,NSPC1), intent(in) :: & - aerodp ! Vertical integrated optical depth for various aerosol species + aerodp ! Vertical integrated optical depth for various aerosol species real(kind_phys), dimension(nCol,5), intent(in) :: & - cldsa ! Fraction of clouds for low, middle, high, total and BL + cldsa ! Fraction of clouds for low, middle, high, total and BL integer, dimension(nCol,3), intent(in) ::& mbota, & ! vertical indices for low, middle and high cloud tops mtopa ! vertical indices for low, middle and high cloud bases @@ -81,10 +81,10 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! nirbm - downward nir direct beam flux (W/m2) ! nirdf - downward nir diffused flux (W/m2) ! visbm - downward uv+vis direct beam flux (W/m2) - ! visdf - downward uv+vis diffused flux (W/m2) - + ! visdf - downward uv+vis diffused flux (W/m2) + real(kind=kind_phys), dimension(:,:), intent(inout) :: fluxr - + ! Outputs (mandatory) real(kind_phys), dimension(nCol), intent(inout) :: & nirbmdi, & ! sfc nir beam sw downward flux (W/m2) @@ -94,7 +94,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky nirbmui, & ! sfc nir beam sw upward flux (W/m2) nirdfui, & ! sfc nir diff sw upward flux (W/m2) visbmui, & ! sfc uv+vis beam sw upward flux (W/m2) - visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) + visdfui, & ! sfc uv+vis diff sw upward flux (W/m2) sfcnsw, & ! total sky sfc netsw flx into ground sfcdsw ! real(kind_phys), dimension(nCol,nLev), intent(inout) :: & @@ -111,7 +111,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky ! Outputs (optional) real(kind_phys),dimension(nCol, nLev),intent(inout),optional :: & htrswc ! Clear-sky heating rate (K/s) - + ! Local variables integer :: i, j, k, itop, ibtc real(kind_phys) :: tem0d, tem1, tem2 @@ -182,15 +182,17 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky htrsw(:,:) = 0.0 sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) topfsw = topfsw_type( 0.0, 0.0, 0.0 ) - nirbmdi(:) = 0.0 - nirdfdi(:) = 0.0 - visbmdi(:) = 0.0 - visdfdi(:) = 0.0 - nirbmui(:) = 0.0 - nirdfui(:) = 0.0 - visbmui(:) = 0.0 - visdfui(:) = 0.0 - + do i=1,nCol + nirbmdi(i) = 0.0 + nirdfdi(i) = 0.0 + visbmdi(i) = 0.0 + visdfdi(i) = 0.0 + nirbmui(i) = 0.0 + nirdfui(i) = 0.0 + visbmui(i) = 0.0 + visdfui(i) = 0.0 + enddo + if (do_sw_clrsky_hr) then htrswc(:,:) = 0 endif @@ -236,7 +238,7 @@ subroutine GFS_rrtmgp_sw_post_run (nCol, nLev, nDay, idxday, lsswr, do_sw_clrsky fluxr(i,27) = fluxr(i,27) + nirdfdi(i) * tem0d ! nir diff sw dn ! SW clear-sky fluxes fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d - fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d + fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d endif enddo diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_sw_post.meta index 6d661b7f1..0e93b78e6 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_sw_post.meta @@ -363,9 +363,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_sw_pre.meta b/physics/GFS_rrtmgp_sw_pre.meta index 1d9f893b6..462ab5f18 100644 --- a/physics/GFS_rrtmgp_sw_pre.meta +++ b/physics/GFS_rrtmgp_sw_pre.meta @@ -116,9 +116,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_thompsonmp_pre.meta b/physics/GFS_rrtmgp_thompsonmp_pre.meta index 82d9a1b95..ff8d0e13b 100644 --- a/physics/GFS_rrtmgp_thompsonmp_pre.meta +++ b/physics/GFS_rrtmgp_thompsonmp_pre.meta @@ -369,9 +369,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_rrtmgp_zhaocarr_pre.meta b/physics/GFS_rrtmgp_zhaocarr_pre.meta index 861b1144d..2eb333115 100644 --- a/physics/GFS_rrtmgp_zhaocarr_pre.meta +++ b/physics/GFS_rrtmgp_zhaocarr_pre.meta @@ -358,9 +358,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_stochastics.meta b/physics/GFS_stochastics.meta index 0b2c1da2f..bf1c3fb25 100644 --- a/physics/GFS_stochastics.meta +++ b/physics/GFS_stochastics.meta @@ -31,7 +31,7 @@ standard_name = sigma_pressure_hybrid_vertical_coordinate long_name = vertical sigma coordinate for radiation initialization units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -52,9 +52,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -495,9 +495,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index f596b86cd..43b3d5efa 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -30,9 +30,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -70,9 +70,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -236,9 +236,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -725,9 +725,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -836,9 +836,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1023,9 +1023,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1468,9 +1468,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1817,9 +1817,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1901,9 +1901,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 14bc48cd7..510b3f427 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -211,6 +211,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) + zorlo(i) = max(1.0e-5, min(one, zorlo(i))) ! DH* else zorlo(i) = huge @@ -233,6 +234,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra tsurf_ice(i) = tisfc(i) ep1d_ice(i) = zero gflx_ice(i) = zero + zorli(i) = max(1.0e-5, min(one, zorli(i))) ! DH* else zorli(i) = huge @@ -256,39 +258,38 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, fra endif enddo ! - if (.not. cplflx .or. kdt == 1) then - if (frac_grid) then - do i=1,im - if (dry(i)) then - if (icy(i)) then + if (frac_grid) then + do i=1,im + if (dry(i)) then + if (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then tem = one / (cice(i)*(one-frland(i))) snowd_ice(i) = max(zero, (snowd(i) - snowd_lnd(i)*frland(i)) * tem) weasd_ice(i) = max(zero, (weasd(i) - weasd_lnd(i)*frland(i)) * tem) endif - elseif (icy(i)) then + endif + elseif (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then tem = one / cice(i) snowd_lnd(i) = zero snowd_ice(i) = snowd(i) * tem weasd_lnd(i) = zero weasd_ice(i) = weasd(i) * tem endif - enddo - else - do i=1,im - if (dry(i)) then - snowd_lnd(i) = snowd(i) - weasd_lnd(i) = weasd(i) - snowd_ice(i) = zero - weasd_ice(i) = zero - elseif (icy(i)) then + endif + enddo + else + do i=1,im + if (icy(i)) then + if (kdt == 1 .or. (.not. cplflx .or. lakefrac(i) > zero)) then snowd_lnd(i) = zero weasd_lnd(i) = zero tem = one / cice(i) snowd_ice(i) = snowd(i) * tem weasd_ice(i) = weasd(i) * tem endif - enddo - endif + endif + enddo endif ! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) @@ -410,8 +411,7 @@ subroutine GFS_surface_composites_post_run ( cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & ep1d_lnd, ep1d_ice, weasd, weasd_lnd, weasd_ice, snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & - qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tisfc, hice, cice, tiice, & -! qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tisfc, hice, cice, min_seaice, tiice, & + qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tisfc, hice, cice, tiice, & sigmaf, zvfun, lheatstrg, h0facu, h0facs, hflxq, hffac, stc, & grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, huge, errmsg, errflg) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index fde52ed23..89048e487 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -479,9 +479,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -613,9 +613,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1650,9 +1650,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 4dcf394db..28c88c5ea 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -94,9 +94,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -310,7 +310,7 @@ [sfc_wts] standard_name = surface_stochastic_weights_from_coupled_process long_name = weights for stochastic surface physics perturbation - units = none + units = 1 dimensions = (horizontal_loop_extent,number_of_perturbed_land_surface_variables) type = real kind = kind_phys @@ -465,9 +465,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -533,9 +533,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1485,9 +1485,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_surface_loop_control.meta b/physics/GFS_surface_loop_control.meta index edb19072a..4a522ff43 100644 --- a/physics/GFS_surface_loop_control.meta +++ b/physics/GFS_surface_loop_control.meta @@ -45,9 +45,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -149,9 +149,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta index 4cd736667..3ec92287a 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -16,9 +16,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -36,9 +36,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -231,9 +231,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/GFS_time_vary_pre.scm.meta index 908d636b0..20708c51e 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/GFS_time_vary_pre.scm.meta @@ -16,9 +16,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -36,9 +36,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -224,9 +224,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/HWRF_mcica_random_numbers.F90 b/physics/HWRF_mcica_random_numbers.F90 deleted file mode 100644 index b2f2d20dd..000000000 --- a/physics/HWRF_mcica_random_numbers.F90 +++ /dev/null @@ -1,109 +0,0 @@ - module mcica_random_numbers - - ! Generic module to wrap random number generators. - ! The module defines a type that identifies the particular stream of random - ! numbers, and has procedures for initializing it and getting real numbers - ! in the range 0 to 1. - ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. - ! - use MersenneTwister, only: randomNumberSequence, & ! The random number engine. - new_RandomNumberSequence, getRandomReal -!! mji -!! use time_manager_mod, only: time_type, get_date - -!mz use parkind, only : im => kind_im, rb => kind_rb - use machine, only: im => kind_io4, rb => kind_phys - - implicit none - private - - type randomNumberStream - type(randomNumberSequence) :: theNumbers - end type randomNumberStream - - interface getRandomNumbers - module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D - end interface getRandomNumbers - - interface initializeRandomNumberStream - module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V - end interface initializeRandomNumberStream - - public :: randomNumberStream, & - initializeRandomNumberStream, getRandomNumbers -!! mji -!! initializeRandomNumberStream, getRandomNumbers, & -!! constructSeed -contains - ! --------------------------------------------------------- - ! Initialization - ! --------------------------------------------------------- - function initializeRandomNumberStream_S(seed) result(new) - integer(kind=im), intent( in) :: seed - type(randomNumberStream) :: new - - new%theNumbers = new_RandomNumberSequence(seed) - - end function initializeRandomNumberStream_S - ! --------------------------------------------------------- - function initializeRandomNumberStream_V(seed) result(new) - integer(kind=im), dimension(:), intent( in) :: seed - type(randomNumberStream) :: new - - new%theNumbers = new_RandomNumberSequence(seed) - - end function initializeRandomNumberStream_V - - ! --------------------------------------------------------- - ! Procedures for drawing random numbers - ! --------------------------------------------------------- - subroutine getRandomNumber_Scalar(stream, number) - type(randomNumberStream), intent(inout) :: stream - real(kind=rb), intent( out) :: number - - number = getRandomReal(stream%theNumbers) - end subroutine getRandomNumber_Scalar - ! --------------------------------------------------------- - subroutine getRandomNumber_1D(stream, numbers) - type(randomNumberStream), intent(inout) :: stream - real(kind=rb), dimension(:), intent( out) :: numbers - - ! Local variables - integer(kind=im) :: i - - do i = 1, size(numbers) - numbers(i) = getRandomReal(stream%theNumbers) - end do - end subroutine getRandomNumber_1D - ! --------------------------------------------------------- - subroutine getRandomNumber_2D(stream, numbers) - type(randomNumberStream), intent(inout) :: stream - real(kind=rb), dimension(:, :), intent( out) :: numbers - - ! Local variables - integer(kind=im) :: i - - do i = 1, size(numbers, 2) - call getRandomNumber_1D(stream, numbers(:, i)) - end do - end subroutine getRandomNumber_2D - -! mji -! ! --------------------------------------------------------- -! ! Constructing a unique seed from grid cell index and model date/time -! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute -! ! --------------------------------------------------------- -! function constructSeed(i, j, time) result(seed) -! integer(kind=im), intent( in) :: i, j -! type(time_type), intent( in) :: time -! integer(kind=im), dimension(8) :: seed -! -! ! Local variables -! integer(kind=im) :: year, month, day, hour, minute, second -! -! -! call get_date(time, year, month, day, hour, minute, second) -! seed = (/ i, j, year, month, day, hour, minute, second /) -! end function constructSeed - - end module mcica_random_numbers diff --git a/physics/HWRF_mersenne_twister.F90 b/physics/HWRF_mersenne_twister.F90 deleted file mode 100644 index f9e3b0b0a..000000000 --- a/physics/HWRF_mersenne_twister.F90 +++ /dev/null @@ -1,304 +0,0 @@ -! Fortran-95 implementation of the Mersenne Twister 19937, following -! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10), -! adapted cosmetically by making the names more general. -! Users must declare one or more variables of type randomNumberSequence in the calling -! procedure which are then initialized using a required seed. If the -! variable is not initialized the random numbers will all be 0. -! For example: -! program testRandoms -! use RandomNumbers -! type(randomNumberSequence) :: randomNumbers -! integer :: i -! -! randomNumbers = new_RandomNumberSequence(seed = 100) -! do i = 1, 10 -! print ('(f12.10, 2x)'), getRandomReal(randomNumbers) -! end do -! end program testRandoms -! -! Fortran-95 implementation by -! Robert Pincus -! NOAA-CIRES Climate Diagnostics Center -! Boulder, CO 80305 -! email: Robert.Pincus@colorado.edu -! -! This documentation in the original C program reads: -! ------------------------------------------------------------- -! A C-program for MT19937, with initialization improved 2002/2/10. -! Coded by Takuji Nishimura and Makoto Matsumoto. -! This is a faster version by taking Shawn Cokus's optimization, -! Matthe Bellew's simplification, Isaku Wada's real version. -! -! Before using, initialize the state by using init_genrand(seed) -! or init_by_array(init_key, key_length). -! -! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, -! All rights reserved. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! -! 3. The names of its contributors may not be used to endorse or promote -! products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! -! -! Any feedback is very welcome. -! http://www.math.keio.ac.jp/matumoto/emt.html -! email: matumoto@math.keio.ac.jp -! ------------------------------------------------------------- - - module MersenneTwister -! ------------------------------------------------------------- - -!mz use parkind, only : im => kind_im, rb => kind_rb - use machine, only: im => kind_io4, rb => kind_phys - - implicit none - private - - ! Algorithm parameters - ! ------- - ! Period parameters - integer(kind=im), parameter :: blockSize = 624, & - M = 397, & - MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL) - UMASK = -2147483647-1, & ! most significant w-r bits (0x80000000UL) - LMASK = 2147483647 ! least significant r bits (0x7fffffffUL) - ! Tempering parameters - integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL) - TMASKC= -272236544 ! (0xefc60000UL) - ! ------- - - ! The type containing the state variable - type randomNumberSequence - integer(kind=im) :: currentElement ! = blockSize - integer(kind=im), dimension(0:blockSize -1) :: state ! = 0 - end type randomNumberSequence - - interface new_RandomNumberSequence - module procedure initialize_scalar, initialize_vector - end interface new_RandomNumberSequence - - - public :: randomNumberSequence - public :: new_RandomNumberSequence, finalize_RandomNumberSequence, & - getRandomInt, getRandomPositiveInt, getRandomReal -! ------------------------------------------------------------- -contains - ! ------------------------------------------------------------- - ! Private functions - ! --------------------------- - function mixbits(u, v) - integer(kind=im), intent( in) :: u, v - integer(kind=im) :: mixbits - - mixbits = ior(iand(u, UMASK), iand(v, LMASK)) - end function mixbits - ! --------------------------- - function twist(u, v) - integer(kind=im), intent( in) :: u, v - integer(kind=im) :: twist - - ! Local variable - integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /) - - twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) - twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im))) - end function twist - ! --------------------------- - subroutine nextState(twister) - type(randomNumberSequence), intent(inout) :: twister - - ! Local variables - integer(kind=im) :: k - - do k = 0, blockSize - M - 1 - twister%state(k) = ieor(twister%state(k + M), & - twist(twister%state(k), twister%state(k + 1_im))) - end do - do k = blockSize - M, blockSize - 2 - twister%state(k) = ieor(twister%state(k + M - blockSize), & - twist(twister%state(k), twister%state(k + 1_im))) - end do - twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), & - twist(twister%state(blockSize - 1_im), twister%state(0_im))) - twister%currentElement = 0_im - - end subroutine nextState - ! --------------------------- - elemental function temper(y) - integer(kind=im), intent(in) :: y - integer(kind=im) :: temper - - integer(kind=im) :: x - - ! Tempering - x = ieor(y, ishft(y, -11)) - x = ieor(x, iand(ishft(x, 7), TMASKB)) - x = ieor(x, iand(ishft(x, 15), TMASKC)) - temper = ieor(x, ishft(x, -18)) - end function temper - ! ------------------------------------------------------------- - ! Public (but hidden) functions - ! -------------------- - function initialize_scalar(seed) result(twister) - integer(kind=im), intent(in ) :: seed - type(randomNumberSequence) :: twister - - integer(kind=im) :: i - ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, - ! MSBs of the seed affect only MSBs of the array state[]. - ! 2002/01/09 modified by Makoto Matsumoto - - twister%state(0) = iand(seed, -1_im) - do i = 1, blockSize - 1 ! ubound(twister%state) - twister%state(i) = 1812433253_im * ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30_im)) + i - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - end do - twister%currentElement = blockSize - end function initialize_scalar - ! ------------------------------------------------------------- - function initialize_vector(seed) result(twister) - integer(kind=im), dimension(0:), intent(in) :: seed - type(randomNumberSequence) :: twister - - integer(kind=im) :: i, j, k, nFirstLoop, nWraps - - nWraps = 0 - twister = initialize_scalar(19650218_im) - - nFirstLoop = max(blockSize, size(seed)) - do k = 1, nFirstLoop - i = mod(k + nWraps, blockSize) - j = mod(k - 1, size(seed)) - if(i == 0) then - twister%state(i) = twister%state(blockSize - 1) - twister%state(1) = ieor(twister%state(1), & - ieor(twister%state(1-1), & - ishft(twister%state(1-1), -30_im)) * 1664525_im) + & - seed(j) + j ! Non-linear - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - nWraps = nWraps + 1 - else - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30_im)) * 1664525_im) + & - seed(j) + j ! Non-linear - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - end if - end do - - ! - ! Walk through the state array, beginning where we left off in the block above - ! - do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1 - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - end do - - twister%state(0) = twister%state(blockSize - 1) - - do i = 1, mod(nFirstLoop, blockSize) + nWraps - twister%state(i) = ieor(twister%state(i), & - ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear - twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines - end do - - twister%state(0) = UMASK - twister%currentElement = blockSize - - end function initialize_vector - ! ------------------------------------------------------------- - ! Public functions - ! -------------------- - function getRandomInt(twister) - type(randomNumberSequence), intent(inout) :: twister - integer(kind=im) :: getRandomInt - ! Generate a random integer on the interval [0,0xffffffff] - ! Equivalent to genrand_int32 in the C code. - ! Fortran doesn't have a type that's unsigned like C does, - ! so this is integers in the range -2**31 - 2**31 - ! All functions for getting random numbers call this one, - ! then manipulate the result - - if(twister%currentElement >= blockSize) call nextState(twister) - - getRandomInt = temper(twister%state(twister%currentElement)) - twister%currentElement = twister%currentElement + 1 - - end function getRandomInt - ! -------------------- - function getRandomPositiveInt(twister) - type(randomNumberSequence), intent(inout) :: twister - integer(kind=im) :: getRandomPositiveInt - ! Generate a random integer on the interval [0,0x7fffffff] - ! or [0,2**31] - ! Equivalent to genrand_int31 in the C code. - - ! Local integers - integer(kind=im) :: localInt - - localInt = getRandomInt(twister) - getRandomPositiveInt = ishft(localInt, -1) - - end function getRandomPositiveInt - ! -------------------- - ! -------------------- -!! mji - modified Jan 2007, double converted to rrtmg real kind type - function getRandomReal(twister) - type(randomNumberSequence), intent(inout) :: twister -! double precision :: getRandomReal - real(kind=rb) :: getRandomReal - ! Generate a random number on [0,1] - ! Equivalent to genrand_real1 in the C code - ! The result is stored as double precision but has 32 bit resolution - - integer(kind=im) :: localInt - - localInt = getRandomInt(twister) - if(localInt < 0) then -! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) - getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb) - else -! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) - getRandomReal = (localInt )/(2.0**32_rb - 1.0_rb) - end if - - end function getRandomReal - ! -------------------- - subroutine finalize_RandomNumberSequence(twister) - type(randomNumberSequence), intent(inout) :: twister - - twister%currentElement = blockSize - twister%state(:) = 0_im - end subroutine finalize_RandomNumberSequence - - ! -------------------- - - end module MersenneTwister - diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index 6efce96f5..c4f0a255d 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -241,54 +241,54 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr ! wrap everything in a do_ugwp 'if test' in order not to break the namelist functionality if (do_ugwp) then ! calling revised old GFS gravity wave drag - ! topo paras - ! w/ orographic effects - if(nmtvr == 14)then - ! calculate sgh30 for TOFD - sgh30 = abs(oro - oro_uf) - ! w/o orographic effects - else - sgh30 = 0. - endif - - zlwb(:) = 0. - - call GWDPS_V0(im, levs, lonr, do_tofd, Pdvdt, Pdudt, Pdtdt, Pkdis, & - ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & - dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & - dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd(1:2), & - me, master, rdxzb, con_g, con_omega, zmtb, zogw, tau_mtb, tau_ogw, & - tau_tofd, dudt_mtb, dudt_ogw, dudt_tms) - - else ! calling old GFS gravity wave drag as is - - do k=1,levs - do i=1,im - Pdvdt(i,k) = 0.0 - Pdudt(i,k) = 0.0 - Pdtdt(i,k) = 0.0 - Pkdis(i,k) = 0.0 - enddo - enddo - - if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then - call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & - ugrs, vgrs, tgrs, qgrs(:,:,1), & - kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & - hprime, oc, oa4, clx, theta, sigma, gamma, & - elvmax, dusfcg, dvsfcg, & - con_g, con_cp, con_rd, con_rv, lonr, & - nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, & - errmsg, errflg) - if (errflg/=0) return + ! topo paras + ! w/ orographic effects + if(nmtvr == 14)then + ! calculate sgh30 for TOFD + sgh30 = abs(oro - oro_uf) + ! w/o orographic effects + else + sgh30 = 0. endif - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - if (ldiag_ugwp) then - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 - end if - - endif ! do_ugwp + zlwb(:) = 0. + + call GWDPS_V0(im, levs, lonr, do_tofd, Pdvdt, Pdudt, Pdtdt, Pkdis, & + ugrs, vgrs, tgrs, qgrs(:,:,1), kpbl, prsi,del,prsl, prslk, phii, phil, & + dtp, kdt, sgh30, hprime, oc, oa4, clx, theta, sigma, gamma, elvmax, & + dusfcg, dvsfcg, xlat_d, sinlat, coslat, area, cdmbgwd(1:2), & + me, master, rdxzb, con_g, con_omega, zmtb, zogw, tau_mtb, tau_ogw, & + tau_tofd, dudt_mtb, dudt_ogw, dudt_tms) + + else ! calling old GFS gravity wave drag as is + + do k=1,levs + do i=1,im + Pdvdt(i,k) = 0.0 + Pdudt(i,k) = 0.0 + Pdtdt(i,k) = 0.0 + Pkdis(i,k) = 0.0 + enddo + enddo + + if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & + ugrs, vgrs, tgrs, qgrs(:,:,1), & + kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & + hprime, oc, oa4, clx, theta, sigma, gamma, & + elvmax, dusfcg, dvsfcg, & + con_g, con_cp, con_rd, con_rv, lonr, & + nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, & + errmsg, errflg) + if (errflg/=0) return + endif + + tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 + if (ldiag_ugwp) then + du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + endif + + endif ! do_ugwp if(ldiag3d .and. lssav .and. .not. flag_for_gwd_generic_tend) then @@ -348,19 +348,20 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr endif call fv3_ugwp_solv2_v0(im, levs, dtp, tgrs, ugrs, vgrs,qgrs(:,:,1), & - prsl, prsi, phil, xlat_d, sinlat, coslat, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & - tau_ngw, me, master, kdt) + prsl, prsi, phil, xlat_d, sinlat, coslat, & + gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, tau_ngw, & + me, master, kdt) do k=1,levs do i=1,im - gw_dtdt(i,k) = pngw*gw_dtdt(i,k)+ pogw*Pdtdt(i,k) - gw_dudt(i,k) = pngw*gw_dudt(i,k)+ pogw*Pdudt(i,k) - gw_dvdt(i,k) = pngw*gw_dvdt(i,k)+ pogw*Pdvdt(i,k) - gw_kdis(i,k) = pngw*gw_kdis(i,k)+ pogw*Pkdis(i,k) + gw_dtdt(i,k) = pngw*gw_dtdt(i,k) + pogw*Pdtdt(i,k) + gw_dudt(i,k) = pngw*gw_dudt(i,k) + pogw*Pdudt(i,k) + gw_dvdt(i,k) = pngw*gw_dvdt(i,k) + pogw*Pdvdt(i,k) + gw_kdis(i,k) = pngw*gw_kdis(i,k) + pogw*Pkdis(i,k) ! accumulation of tendencies for CCPP to replicate EMC-physics updates (!! removed in latest code commit to VLAB) - !dudt(i,k) = dudt(i,k) +gw_dudt(i,k) - !dvdt(i,k) = dvdt(i,k) +gw_dvdt(i,k) - !dtdt(i,k) = dtdt(i,k) +gw_dtdt(i,k) + !dudt(i,k) = dudt(i,k) + gw_dudt(i,k) + !dvdt(i,k) = dvdt(i,k) + gw_dvdt(i,k) + !dtdt(i,k) = dtdt(i,k) + gw_dtdt(i,k) enddo enddo diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index 0d4cbcfd8..bf94edd26 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -78,7 +78,7 @@ standard_name = sigma_pressure_hybrid_coordinate_a_coefficient long_name = a parameter for sigma pressure level calculations units = Pa - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -86,7 +86,7 @@ standard_name = sigma_pressure_hybrid_coordinate_b_coefficient long_name = b parameter for sigma pressure level calculations units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -161,9 +161,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -181,9 +181,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -858,9 +858,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cires_ugwp_post.meta b/physics/cires_ugwp_post.meta index 0faca669f..5add9d43f 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/cires_ugwp_post.meta @@ -269,9 +269,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cnvc90.meta b/physics/cnvc90.meta index 9c2a626fa..9728266d4 100644 --- a/physics/cnvc90.meta +++ b/physics/cnvc90.meta @@ -116,9 +116,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cs_conv.meta b/physics/cs_conv.meta index 68189d776..90a411031 100644 --- a/physics/cs_conv.meta +++ b/physics/cs_conv.meta @@ -141,9 +141,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -204,9 +204,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -613,9 +613,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cs_conv_aw_adj.meta b/physics/cs_conv_aw_adj.meta index f3c205772..0dada0fd5 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/cs_conv_aw_adj.meta @@ -173,9 +173,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 102179bee..f59a985cd 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -47,6 +47,27 @@ module cu_gf_deep contains + integer function my_maxloc1d(A,N,dir) +!$acc routine vector + implicit none + real(kind_phys), intent(in) :: A(:) + integer, intent(in) :: N,dir + + real(kind_phys) :: imaxval + integer :: i + + imaxval = MAXVAL(A) + my_maxloc1d = 1 +!$acc loop + do i = 1, N + if ( A(i) == imaxval ) then + my_maxloc1d = i + return + endif + end do + return + end function my_maxloc1d + !>\ingroup cu_gf_deep_group !> \section general_gf_deep GF Deep Convection General Algorithm !> @{ @@ -111,9 +132,7 @@ subroutine cu_gf_deep_run( & !! more is possible, talk to developer or !! implement yourself. pattern is expected to be !! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) ,do_capsuppress,cap_suppress_j & ! -#endif ,k22 & ! ,jmin,tropics) ! @@ -128,21 +147,16 @@ subroutine cu_gf_deep_run( & ,intent (in ) :: rand_clos real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: rand_mom,rand_vmas +!$acc declare copyin(rand_clos,rand_mom,rand_vmas) -#if ( wrf_dfi_radar == 1 ) -! -! option of cap suppress: -! do_capsuppress = 1 do -! do_capsuppress = other don't -! -! - integer, intent(in ) ,optional :: do_capsuppress - real(kind=kind_phys), dimension( its:ite ) :: cap_suppress_j -#endif + integer, intent(in) :: do_capsuppress + real(kind=kind_phys), intent(in), dimension(:) :: cap_suppress_j +!$acc declare create(cap_suppress_j) ! ! ! real(kind=kind_phys), dimension (its:ite,1:maxens3) :: xf_ens,pr_ens +!$acc declare create(xf_ens,pr_ens) ! outtem = output temp tendency (per s) ! outq = output q tendency (per s) ! outqc = output qc tendency (per s) @@ -156,15 +170,19 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & pre,xmb_out +!$acc declare copy(cnvwt,outu,outv,outt,outq,outqc,cupclw,frh_out,pre,xmb_out) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & hfx,qfx,xmbm_in,xmbs_in +!$acc declare copyin(hfx,qfx,xmbm_in,xmbs_in) integer, dimension (its:ite) & ,intent (inout ) :: & kbcon,ktop +!$acc declare copy(kbcon,ktop) integer, dimension (its:ite) & ,intent (in ) :: & kpbl,tropics +!$acc declare copyin(kpbl,tropics) ! ! basic environmental input includes moisture convergence (mconv) ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off @@ -173,18 +191,23 @@ subroutine cu_gf_deep_run( & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & dhdt,rho,t,po,us,vs,tn +!$acc declare copyin(dhdt,rho,t,po,us,vs,tn) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & omeg +!$acc declare copy(omeg) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & q,qo,zuo,zdo,zdm +!$acc declare copy(q,qo,zuo,zdo,zdm) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & dx,z1,psur,xland +!$acc declare copyin(dx,z1,psur,xland) real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & mconv,ccn +!$acc declare copy(mconv,ccn) real(kind=kind_phys) & @@ -201,6 +224,7 @@ subroutine cu_gf_deep_run( & edtc real(kind=kind_phys), dimension (its:ite,kts:kte,1) :: & dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens +!$acc declare create(xaa0_ens,edtc,dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens) ! ! ! @@ -285,6 +309,17 @@ subroutine cu_gf_deep_run( & cd,cdd,dellah,dellaq,dellat,dellaqc, & u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv +!$acc declare create( & +!$acc entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo, & +!$acc xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup, & +!$acc p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup, & +!$acc zo_cup,po_cup,gammao_cup,tn_cup, & +!$acc xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & +!$acc xt_cup, dby,hc,zu,clw_all, & +!$acc dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco, & +!$acc dbyt,xdby,xhc,xzu, & +!$acc cd,cdd,dellah,dellaq,dellat,dellaqc, & +!$acc u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv) ! aa0 cloud work function for downdraft ! edt = epsilon @@ -304,9 +339,18 @@ subroutine cu_gf_deep_run( & integer, dimension (its:ite) :: & kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & ktopdby,kbconx,ierr2,ierr3,kbmax +!$acc declare create(edt,edto,edtm,aa1,aa0,xaa0,hkb, & +!$acc hkbo,xhkb, & +!$acc xmb,pwavo,ccnloss, & +!$acc pwevo,bu,bud,cap_max, & +!$acc cap_max_increment,closure_n,psum,psumh,sig,sigd, & +!$acc axx,edtmax,edtmin,entr_rate, & +!$acc kzdown,kdet,k22,jmin,kstabi,kstabm,k22x,xland1, & +!$acc ktopdby,kbconx,ierr2,ierr3,kbmax) integer, dimension (its:ite), intent(inout) :: ierr integer, dimension (its:ite), intent(in) :: csum +!$acc declare copy(ierr) copyin(csum) integer :: & iloop,nens3,ki,kk,i,k real(kind=kind_phys) :: & @@ -317,9 +361,11 @@ subroutine cu_gf_deep_run( & detup,subdown,entdoj,entupk,detupk,totmas real(kind=kind_phys), dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec +!$acc declare create(lambau,flux_tun,zws,ztexec,zqexec) integer :: jprnt,jmini,start_k22 logical :: keep_going,flg(its:ite) +!$acc declare create(flg) character*50 :: ierrc(its:ite) character*4 :: cumulus @@ -328,9 +374,12 @@ subroutine cu_gf_deep_run( & ,up_massentro,up_massdetro,dd_massentro,dd_massdetro real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentru,up_massdetru,dd_massentru,dd_massdetru +!$acc declare create(up_massentr,up_massdetr,c1d,up_massentro,up_massdetro,dd_massentro,dd_massdetro, & +!$acc up_massentru,up_massdetru,dd_massentru,dd_massdetru) real(kind=kind_phys) c1_max,buo_flux,pgcon,pgc,blqe real(kind=kind_phys) :: xff_mid(its:ite,2) +!$acc declare create(xff_mid) integer :: iversion=1 real(kind=kind_phys) :: denom,h_entr,umean,t_star,dq integer, intent(in) :: dicycle @@ -339,32 +388,46 @@ subroutine cu_gf_deep_run( & ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl & ,gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl real(kind=kind_phys), dimension(its:ite) :: xf_dicycle +!$acc declare create(aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean, & +!$acc tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl, & +!$acc qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl, & +!$acc gammao_cup_bl,tn_cup_bl,hco_bl,dbyo_bl,xf_dicycle) real(kind=kind_phys), intent(inout), dimension(its:ite,10) :: forcing +!$acc declare copy(forcing) integer :: turn,pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers real(kind=kind_phys), dimension (its:ite) :: c0 ! HCB +!$acc declare create(pmin_lev,start_level,ktopkeep,dtempdz,k_inv_layers,c0) ! rainevap from sas real(kind=kind_phys) zuh2(40) real(kind=kind_phys), dimension (its:ite) :: rntot,delqev,delq2,qevap,rn,qcond +!$acc declare create(zuh2,rntot,delqev,delq2,qevap,rn,qcond) real(kind=kind_phys) :: rain,t1,q1,elocp,evef,el2orc,evfact,evfactl,g_rain,e_dn,c_up real(kind=kind_phys) :: pgeoh,dts,fp,fpi,pmin,x_add,beta,beta_u real(kind=kind_phys) :: cbeg,cmid,cend,const_a,const_b,const_c !---meltglac------------------------------------------------- real(kind=kind_phys), dimension (its:ite,kts:kte) :: p_liq_ice,melting_layer,melting +!$acc declare create(p_liq_ice,melting_layer,melting) + + integer :: itemp !---meltglac------------------------------------------------- +!$acc kernels melting_layer(:,:)=0. melting(:,:)=0. flux_tun(:)=fluxtune +!$acc end kernels ! if(imid.eq.1)flux_tun(:)=fluxtune+.5 cumulus='deep' if(imid.eq.1)cumulus='mid' pmin=150. if(imid.eq.1)pmin=75. +!$acc kernels ktopdby(:)=0 +!$acc end kernels c1_max=c1 elocp=xlv/cp el2orc=xlv*xlv/(r_v*cp) @@ -380,18 +443,21 @@ subroutine cu_gf_deep_run( & ! ! ecmwf pgcon=0. +!$acc kernels lambau(:)=2.0 if(imid.eq.1)lambau(:)=2.0 ! here random must be between -1 and 1 if(nranflag == 1)then lambau(:)=1.5+rand_mom(:) endif +!$acc end kernels ! sas ! lambau=0. ! pgcon=-.55 ! !---------------------------------------------------- ! HCB ! Set cloud water to rain water conversion rate (c0) +!$acc kernels c0(:)=0.004 do i=its,itf xland1(i)=int(xland(i)+.0001) ! 1. @@ -403,8 +469,10 @@ subroutine cu_gf_deep_run( & c0(i)=0.002 endif enddo +!$acc end kernels !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!$acc kernels ztexec(:) = 0. zqexec(:) = 0. zws(:) = 0. @@ -429,10 +497,12 @@ subroutine cu_gf_deep_run( & zws(i) = 1.2*zws(i)**.3333 zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct enddo +!$acc end kernels ! cap_maxs=225. ! if(imid.eq.1)cap_maxs=150. cap_maxs=75. ! 150. ! if(imid.eq.1)cap_maxs=100. +!$acc kernels do i=its,itf edto(i)=0. closure_n(i)=16. @@ -451,18 +521,40 @@ subroutine cu_gf_deep_run( & if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25. if(ztexec(i).lt.0.)cap_max(i)=cap_max(i)-25. endif +#ifndef _OPENACC ierrc(i)=" " +#endif ! cap_max_increment(i)=1. enddo +!$acc end kernels if(use_excess == 0 )then +!$acc kernels ztexec(:)=0 zqexec(:)=0 +!$acc end kernels + endif + if(do_capsuppress == 1) then +!$acc kernels + do i=its,itf + cap_max(i)=cap_maxs + if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then + cap_max(i)=cap_maxs+75. + elseif (abs(cap_suppress_j(i) - 0.0 ) < 0.1 ) then + cap_max(i)=10.0 + endif + enddo +!$acc end kernels endif ! !--- initial entrainment rate (these may be changed later on in the !--- program ! +!$acc kernels start_level(:)=kte +!$acc end kernels + +!$acc kernels +!$acc loop private(radius,frh) do i=its,ite c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001) entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6 @@ -479,6 +571,7 @@ subroutine cu_gf_deep_run( & sig(i)=(1.-frh)**2 frh_out(i) = frh enddo +!$acc end kernels sig_thresh = (1.-frh_thresh)**2 @@ -488,6 +581,7 @@ subroutine cu_gf_deep_run( & ! !--- initial detrainmentrates ! +!$acc kernels do k=kts,ktf do i=its,itf cnvwt(i,k)=0. @@ -504,14 +598,17 @@ subroutine cu_gf_deep_run( & dellaqc(i,k)=0. enddo enddo +!$acc end kernels ! !--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft ! base mass flux ! +!$acc kernels edtmax(:)=1. if(imid.eq.1)edtmax(:)=.15 edtmin(:)=.1 if(imid.eq.1)edtmin(:)=.05 +!$acc end kernels ! !--- minimum depth (m), clouds must have ! @@ -521,6 +618,7 @@ subroutine cu_gf_deep_run( & !--- maximum depth (mb) of capping !--- inversion (larger cap = no convection) ! +!$acc kernels do i=its,itf ! if(imid.eq.0)then ! edtmax(i)=max(0.5,.8-float(csum(i))*.015) !.3) @@ -533,8 +631,9 @@ subroutine cu_gf_deep_run( & kstabm(i)=ktf-1 ierr2(i)=0 ierr3(i)=0 - x_add=0. enddo +!$acc end kernels + x_add=0. ! do i=its,itf ! cap_max(i)=cap_maxs ! cap_max3(i)=25. @@ -559,13 +658,14 @@ subroutine cu_gf_deep_run( & ! !--- environmental conditions, first heights ! +!$acc kernels do i=its,itf do k=1,maxens3 xf_ens(i,k)=0. pr_ens(i,k)=0. enddo enddo - +!$acc end kernels ! !> - Call cup_env() to calculate moist static energy, heights, qes ! @@ -596,6 +696,7 @@ subroutine cu_gf_deep_run( & call get_partition_liq_ice(ierr,tn,po_cup,p_liq_ice,melting_layer,& itf,ktf,its,ite,kts,kte,cumulus) !---meltglac------------------------------------------------- +!$acc kernels do i=its,itf if(ierr(i).eq.0)then if(kpbl(i).gt.5 .and. imid.eq.1)cap_max(i)=po_cup(i,kpbl(i)) @@ -629,29 +730,36 @@ subroutine cu_gf_deep_run( & ! endif enddo +!$acc end kernels + ! ! ! !> - Determine level with highest moist static energy content (\p k22) ! start_k22=2 +!$acc parallel loop do 36 i=its,itf if(ierr(i).eq.0)then k22(i)=maxloc(heo_cup(i,start_k22:kbmax(i)+2),1)+start_k22-1 if(k22(i).ge.kbmax(i))then ierr(i)=2 +#ifndef _OPENACC ierrc(i)="could not find k22" +#endif ktop(i)=0 k22(i)=0 kbcon(i)=0 endif endif 36 continue +!$acc end parallel + ! !> - call get_cloud_bc() and cup_kbcon() to determine the !! level of convective cloud base (\p kbcon) ! - +!$acc parallel loop private(x_add) do i=its,itf if(ierr(i).eq.0)then x_add = xlv*zqexec(i)+cp*ztexec(i) @@ -659,6 +767,8 @@ subroutine cu_gf_deep_run( & call get_cloud_bc(kte,heo_cup (i,1:kte),hkbo (i),k22(i),x_add) endif ! ierr enddo +!$acc end parallel + jprnt=0 iloop=1 if(imid.eq.1)iloop=5 @@ -674,6 +784,7 @@ subroutine cu_gf_deep_run( & call cup_minimi(heso_cup,kbcon,kstabm,kstabi,ierr, & itf,ktf, & its,ite, kts,kte) +!$acc parallel loop private(frh,x_add) do i=its,itf if(ierr(i) == 0)then frh = min(qo_cup(i,kbcon(i))/qeso_cup(i,kbcon(i)),1.) @@ -686,6 +797,7 @@ subroutine cu_gf_deep_run( & ! ! if(imid.eq.0 .and. xland1(i).eq.0)x_add=150. x_add=0. +!$acc loop seq do k=kbcon(i)+1,ktf if(po(i,kbcon(i))-po(i,k) > pmin+x_add)then pmin_lev(i)=k @@ -700,6 +812,8 @@ subroutine cu_gf_deep_run( & call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add) endif enddo +!$acc end parallel + ! !--- get inversion layers for mid level cloud tops ! @@ -707,6 +821,7 @@ subroutine cu_gf_deep_run( & call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers, & kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) endif +!$acc kernels do i=its,itf if(kstabi(i).lt.kbcon(i))then kbcon(i)=1 @@ -729,6 +844,7 @@ subroutine cu_gf_deep_run( & ktop(i)=min(kstabi(i),k_inv_layers(i,2)) ktopdby(i)=ktop(i) else +!$acc loop seq do k=kbcon(i)+1,ktf if((po_cup(i,k22(i))-po_cup(i,k)).gt.500.)then ktop(i)=k @@ -741,6 +857,8 @@ subroutine cu_gf_deep_run( & endif enddo +!$acc end kernels + ! !> - Call rates_up_pdf() to get normalized mass flux, entrainment and detrainmentrates for updraft ! @@ -757,20 +875,24 @@ subroutine cu_gf_deep_run( & ! ! ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then if(k22(i).gt.1)then +!$acc loop independent do k=1,k22(i) -1 zuo(i,k)=0. zu (i,k)=0. xzu(i,k)=0. enddo endif +!$acc loop independent do k=k22(i),ktop(i) xzu(i,k)= zuo(i,k) zu (i,k)= zuo(i,k) enddo +!$acc loop independent do k=ktop(i)+1,kte zuo(i,k)=0. zu (i,k)=0. @@ -778,6 +900,7 @@ subroutine cu_gf_deep_run( & enddo endif enddo +!$acc end kernels ! !> - Call get_lateral_massflux() to calculate mass entrainment and detrainment ! @@ -785,12 +908,12 @@ subroutine cu_gf_deep_run( & call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'mid',kbcon,k22,up_massentru,up_massdetru,lambau) + ,3,kbcon,k22,up_massentru,up_massdetru,lambau) else call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'deep',kbcon,k22,up_massentru,up_massdetru,lambau) + ,1,kbcon,k22,up_massentru,up_massdetru,lambau) endif @@ -798,6 +921,7 @@ subroutine cu_gf_deep_run( & ! note: ktop here already includes overshooting, ktopdby is without ! overshooting ! +!$acc kernels do k=kts,ktf do i=its,itf uc (i,k)=0. @@ -823,17 +947,19 @@ subroutine cu_gf_deep_run( & hco(i,k)=hkbo(i) endif enddo - +!$acc end kernels ! !---meltglac------------------------------------------------- ! !--- 1st guess for moist static energy and dbyo (not including ice phase) ! +!$acc parallel loop private(denom,kk,ki) do i=its,itf ktopkeep(i)=0 dbyt(i,:)=0. if(ierr(i) /= 0) cycle ktopkeep(i)=ktop(i) +!$acc loop seq do k=start_level(i) +1,ktop(i) !mass cons option denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) @@ -847,8 +973,9 @@ subroutine cu_gf_deep_run( & dbyo(i,k)=hco(i,k)-heso_cup(i,k) enddo ! for now no overshooting (only very little) - kk=maxloc(dbyt(i,:),1) - ki=maxloc(zuo(i,:),1) + !kk=maxloc(dbyt(i,:),1) + !ki=maxloc(zuo(i,:),1) +!$acc loop seq do k=ktop(i)-1,kbcon(i),-1 if(dbyo(i,k).gt.0.)then ktopkeep(i)=k+1 @@ -858,12 +985,16 @@ subroutine cu_gf_deep_run( & !ktop(i)=ktopkeep(i) !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) enddo +!$acc end parallel + +!$acc kernels do 37 i=its,itf kzdown(i)=0 if(ierr(i).eq.0)then zktop=(zo_cup(i,ktop(i))-z1(i))*.6 if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4 zktop=min(zktop+z1(i),zcutdown+z1(i)) +!$acc loop seq do k=kts,ktf if(zo_cup(i,k).gt.zktop)then kzdown(i)=k @@ -873,12 +1004,15 @@ subroutine cu_gf_deep_run( & enddo endif 37 continue +!$acc end kernels + ! !--- downdraft originating level - jmin ! call cup_minimi(heso_cup,k22,kzdown,jmin,ierr, & itf,ktf, & its,ite, kts,kte) +!$acc kernels do 100 i=its,itf if(ierr(i).eq.0)then ! @@ -899,6 +1033,7 @@ subroutine cu_gf_deep_run( & hcdo(i,ki)=heso_cup(i,ki) dz=zo_cup(i,ki+1)-zo_cup(i,ki) dh=0. +!$acc loop seq do k=ki-1,1,-1 hcdo(i,k)=heso_cup(i,jmini) dz=zo_cup(i,k+1)-zo_cup(i,k) @@ -909,7 +1044,9 @@ subroutine cu_gf_deep_run( & keep_going = .true. else ierr(i) = 9 +#ifndef _OPENACC ierrc(i) = "could not find jmini9" +#endif exit endif endif @@ -918,7 +1055,9 @@ subroutine cu_gf_deep_run( & jmin(i) = jmini if ( jmini .le. 5 ) then ierr(i)=4 +#ifndef _OPENACC ierrc(i) = "could not find jmini4" +#endif endif endif 100 continue @@ -945,12 +1084,13 @@ subroutine cu_gf_deep_run( & ! endif ! enddo ! if(imid.eq.1)c1d(i,:)=0.003 - +!$acc loop independent do k=ktop(i)+1,ktf hco(i,k)=heso_cup(i,k) dbyo(i,k)=0. enddo enddo +!$acc end kernels ! !> - Call cup_up_moisture() to calculate moisture properties of updraft ! @@ -975,13 +1115,14 @@ subroutine cu_gf_deep_run( & ! ,itf,ktf,its,ite, kts,kte, cumulus ) !---meltglac------------------------------------------------- - +!$acc kernels do i=its,itf ktopkeep(i)=0 dbyt(i,:)=0. if(ierr(i) /= 0) cycle ktopkeep(i)=ktop(i) +!$acc loop seq do k=start_level(i) +1,ktop(i) !mass cons option denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1) @@ -1027,6 +1168,7 @@ subroutine cu_gf_deep_run( & ! ierr(i)=423 ! endif ! +!$acc loop seq do k=ktop(i)-1,kbcon(i),-1 if(dbyo(i,k).gt.0.)then ktopkeep(i)=k+1 @@ -1036,7 +1178,10 @@ subroutine cu_gf_deep_run( & !ktop(i)=ktopkeep(i) !if(ierr(i).eq.0)ktop(i)=ktopkeep(i) enddo +!$acc end kernels + 41 continue +!$acc kernels do i=its,itf if(ierr(i) /= 0) cycle do k=ktop(i)+1,ktf @@ -1061,10 +1206,14 @@ subroutine cu_gf_deep_run( & if(ierr(i)/=0)cycle if(ktop(i).lt.kbcon(i)+2)then ierr(i)=5 +#ifndef _OPENACC ierrc(i)='ktop too small deep' +#endif ktop(i)=0 endif enddo +!$acc end kernels + !! do 37 i=its,itf ! kzdown(i)=0 ! if(ierr(i).eq.0)then @@ -1133,20 +1282,25 @@ subroutine cu_gf_deep_run( & ! - must have at least depth_min m between cloud convective base ! and cloud top. ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then if ( jmin(i) - 1 .lt. kdet(i) ) kdet(i) = jmin(i)-1 if(-zo_cup(i,kbcon(i))+zo_cup(i,ktop(i)).lt.depth_min)then ierr(i)=6 +#ifndef _OPENACC ierrc(i)="cloud depth very shallow" +#endif endif endif enddo +!$acc end kernels ! !--- normalized downdraft mass flux profile,also work on bottom detrainment !--- in this routine ! +!$acc kernels do k=kts,ktf do i=its,itf zdo(i,k)=0. @@ -1162,6 +1316,9 @@ subroutine cu_gf_deep_run( & mentrd_rate_2d(i,k)=entr_rate(i) enddo enddo +!$acc end kernels + +!$acc parallel loop private(beta,itemp,dzo,h_entr) do i=its,itf if(ierr(i)/=0)cycle beta=max(.025,.055-float(csum(i))*.0015) !.02 @@ -1174,7 +1331,8 @@ subroutine cu_gf_deep_run( & cdd(i,jmin(i))=0. dd_massdetro(i,:)=0. dd_massentro(i,:)=0. - call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.0_kind_phys,ipr,xland1(i),zuh2,"down",ierr(i),kdet(i),jmin(i)+1,zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i)) + call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.0_kind_phys,ipr,xland1(i),zuh2,4, & + ierr(i),kdet(i),jmin(i)+1,zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i)) if(zdo(i,jmin(i)) .lt.1.e-8)then zdo(i,jmin(i))=0. jmin(i)=jmin(i)-1 @@ -1185,8 +1343,9 @@ subroutine cu_gf_deep_run( & cycle endif endif - - do ki=jmin(i) ,maxloc(zdo(i,:),1),-1 + + itemp = maxloc(zdo(i,:),1) + do ki=jmin(i) , itemp,-1 !=> from jmin to maximum value zd -> change entrainment dzo=zo_cup(i,ki+1)-zo_cup(i,ki) dd_massdetro(i,ki)=cdd(i,ki)*dzo*zdo(i,ki+1) @@ -1199,7 +1358,7 @@ subroutine cu_gf_deep_run( & if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1)) enddo mentrd_rate_2d(i,1)=0. - do ki=maxloc(zdo(i,:),1)-1,1,-1 + do ki=itemp-1,1,-1 !=> from maximum value zd to surface -> change detrainment dzo=zo_cup(i,ki+1)-zo_cup(i,ki) dd_massentro(i,ki)=mentrd_rate_2d(i,ki)*dzo*zdo(i,ki+1) @@ -1244,6 +1403,7 @@ subroutine cu_gf_deep_run( & dbydo(i,jmin(i))=hcdo(i,jmin(i))-heso_cup(i,jmin(i)) bud(i)=dbydo(i,jmin(i))*(zo_cup(i,jmin(i)+1)-zo_cup(i,jmin(i))) ucd(i,jmin(i)+1)=.5*(uc(i,jmin(i)+1)+u_cup(i,jmin(i)+1)) +!$acc loop seq do ki=jmin(i) ,1,-1 dzo=zo_cup(i,ki+1)-zo_cup(i,ki) h_entr=.5*(heo(i,ki)+.5*(hco(i,ki)+hco(i,ki+1))) @@ -1268,9 +1428,13 @@ subroutine cu_gf_deep_run( & if(bud(i).gt.0)then ierr(i)=7 +#ifndef _OPENACC ierrc(i)='downdraft is not negatively buoyant ' +#endif endif enddo +!$acc end parallel + ! !> - Call cup_dd_moisture() to calculate moisture properties of downdraft ! @@ -1299,6 +1463,7 @@ subroutine cu_gf_deep_run( & ! its,ite, kts,kte) ! endif !---meltglac------------------------------------------------- +!$acc kernels do i=its,itf if(ierr(i)/=0)cycle do k=kts+1,ktop(i) @@ -1307,6 +1472,7 @@ subroutine cu_gf_deep_run( & cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp enddo enddo +!$acc end kernels ! !> - Call cup_up_aa0() to calculate workfunctions for updrafts ! @@ -1318,20 +1484,28 @@ subroutine cu_gf_deep_run( & kbcon,ktop,ierr, & itf,ktf, & its,ite, kts,kte) + +!$acc kernels do i=its,itf if(ierr(i)/=0)cycle if(aa1(i).eq.0.)then ierr(i)=17 +#ifndef _OPENACC ierrc(i)="cloud work function zero" +#endif endif enddo +!$acc end kernels + ! !--- diurnal cycle closure ! !--- aa1 from boundary layer (bl) processes only +!$acc kernels aa1_bl (:) = 0.0 xf_dicycle (:) = 0.0 tau_ecmwf (:) = 0. +!$acc end kernels !- way to calculate the fraction of cape consumed by shallow convection iversion=1 ! ecmwf !iversion=0 ! orig @@ -1341,6 +1515,7 @@ subroutine cu_gf_deep_run( & ! wmean is of no meaning over land.... ! still working on replacing it over water ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then !- mean vertical velocity @@ -1353,8 +1528,11 @@ subroutine cu_gf_deep_run( & endif enddo tau_bl(:) = 0. +!$acc end kernels + ! if(dicycle == 1) then +!$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -1369,6 +1547,7 @@ subroutine cu_gf_deep_run( & endif enddo +!$acc end kernels if(iversion == 1) then !-- version ecmwf @@ -1380,7 +1559,7 @@ subroutine cu_gf_deep_run( & zo_cup,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & kbcon,ktop,ierr, & itf,ktf,its,ite, kts,kte) - +!$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -1395,11 +1574,13 @@ subroutine cu_gf_deep_run( & !endif endif enddo +!$acc end kernels else !- version for real cloud-work function +!$acc kernels !-get the profiles modified only by bl tendencies do i=its,itf tn_bl(i,:)=0.;qo_bl(i,:)=0. @@ -1412,6 +1593,7 @@ subroutine cu_gf_deep_run( & qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf) endif enddo +!$acc end kernels !--- calculate moist static energy, heights, qes, ... only by bl tendencies call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1, & psur,ierr,tcrit,-1, & @@ -1421,6 +1603,7 @@ subroutine cu_gf_deep_run( & heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, & ierr,z1, & itf,ktf,its,ite, kts,kte) +!$acc kernels do i=its,itf if(ierr(i).eq.0)then hkbo_bl(i)=heo_cup_bl(i,k22(i)) @@ -1458,12 +1641,12 @@ subroutine cu_gf_deep_run( & enddo endif enddo - +!$acc end kernels !--- calculate workfunctions for updrafts call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & kbcon,ktop,ierr, & itf,ktf,its,ite, kts,kte) - +!$acc kernels do i=its,itf if(ierr(i).eq.0)then @@ -1476,14 +1659,18 @@ subroutine cu_gf_deep_run( & ! !- multiply aa1_bl the "normalized time-scale" - tau_bl/ model_timestep aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime !endif - print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) +#ifndef _OPENACC + print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i) +#endif endif enddo +!$acc end kernels endif endif ! version of implementation - +!$acc kernels axx(:)=aa1(:) +!$acc end kernels ! !> - Call cup_dd_edt() to determine downdraft strength in terms of windshear @@ -1501,6 +1688,7 @@ subroutine cu_gf_deep_run( & call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & ,pwo,edto,pwdo,melting & ,itf,ktf,its,ite, kts,kte, cumulus ) +!$acc kernels do k=kts,ktf do i=its,itf dellat_ens (i,k,1)=0. @@ -1524,6 +1712,7 @@ subroutine cu_gf_deep_run( & dellaqc(i,k)=0. enddo enddo +!$acc end kernels ! !---------------------------------------------- cloud level ktop ! @@ -1563,7 +1752,7 @@ subroutine cu_gf_deep_run( & !---------------------------------------------- cloud level 2 ! !- - - - - - - - - - - - - - - - - - - - - - - - model level 1 - +!$acc kernels do i=its,itf if(ierr(i)/=0)cycle dp=100.*(po_cup(i,1)-po_cup(i,2)) @@ -1603,8 +1792,10 @@ subroutine cu_gf_deep_run( & totmas=subin-subdown+detup-entup-entdo+ & detdo-entupk-entdoj+detupk+zuo(i,k+1)-zuo(i,k) if(abs(totmas).gt.1.e-6)then +#ifndef _OPENACC write(0,123)'totmas=',k22(i),kbcon(i),k,entup,detup,edto(i),zdo(i,k+1),dd_massdetro(i,k),dd_massentro(i,k) 123 format(a7,1x,3i3,2e12.4,1(1x,f5.2),3e12.4) +#endif endif dp=100.*(po_cup(i,k)-po_cup(i,k+1)) pgc=pgcon @@ -1706,11 +1897,14 @@ subroutine cu_gf_deep_run( & endif enddo +!$acc end kernels + 444 format(1x,i2,1x,7e12.4) !,1x,f7.2,2x,e13.5) ! !--- using dellas, calculate changed environmental profiles ! mbdt=.1 +!$acc kernels do i=its,itf xaa0_ens(i,1)=0. enddo @@ -1743,6 +1937,7 @@ subroutine cu_gf_deep_run( & xt(i,ktf)=tn(i,ktf) endif enddo +!$acc end kernels ! !--- calculate moist static energy, heights, qes ! @@ -1764,12 +1959,15 @@ subroutine cu_gf_deep_run( & ! !--- moist static energy inside cloud ! +!$acc kernels do k=kts,ktf do i=its,itf xhc(i,k)=0. xdby(i,k)=0. enddo enddo +!$acc end kernels +!$acc parallel loop private(x_add,k) do i=its,itf if(ierr(i).eq.0)then x_add = xlv*zqexec(i)+cp*ztexec(i) @@ -1781,10 +1979,13 @@ subroutine cu_gf_deep_run( & xhc(i,k)=xhkb(i) endif !ierr enddo +!$acc end parallel ! ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then +!$acc loop seq do k=start_level(i) +1,ktop(i) xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1) + & up_massentro(i,k-1)*xhe(i,k-1)) / & @@ -1800,13 +2001,14 @@ subroutine cu_gf_deep_run( & xdby(i,k)=xhc(i,k)-xhes_cup(i,k) enddo +!$acc loop independent do k=ktop(i)+1,ktf xhc (i,k)=xhes_cup(i,k) xdby(i,k)=0. enddo endif enddo - +!$acc end kernels ! !--- workfunctions for updraft ! @@ -1814,10 +2016,13 @@ subroutine cu_gf_deep_run( & kbcon,ktop,ierr, & itf,ktf, & its,ite, kts,kte) +!$acc parallel loop do i=its,itf if(ierr(i).eq.0)then xaa0_ens(i,1)=xaa0(i) +!$acc loop seq do k=kts,ktop(i) +!$acc loop independent do nens3=1,maxens3 if(nens3.eq.7)then !--- b=0 @@ -1839,7 +2044,9 @@ subroutine cu_gf_deep_run( & enddo if(pr_ens(i,7).lt.1.e-6)then ierr(i)=18 +#ifndef _OPENACC ierrc(i)="total normalized condensate too small" +#endif do nens3=1,maxens3 pr_ens(i,nens3)=0. enddo @@ -1851,6 +2058,7 @@ subroutine cu_gf_deep_run( & enddo endif enddo +!$acc end parallel 200 continue ! !--- large scale forcing @@ -1860,11 +2068,13 @@ subroutine cu_gf_deep_run( & ! ensemble is chosen ! ! +!$acc kernels do i=its,itf ierr2(i)=ierr(i) ierr3(i)=ierr(i) k22x(i)=k22(i) enddo +!$acc end kernels call cup_maximi(heo_cup,2,kbmax,k22x,ierr, & itf,ktf, & its,ite, kts,kte) @@ -1885,15 +2095,18 @@ subroutine cu_gf_deep_run( & ! !--- calculate cloud base mass flux ! - +!$acc kernels do i = its,itf mconv(i) = 0 if(ierr(i)/=0)cycle +!$acc loop independent do k=1,ktop(i) dq=(qo_cup(i,k+1)-qo_cup(i,k)) +!$acc atomic update mconv(i)=mconv(i)+omeg(i,k)*dq/g enddo enddo +!$acc end kernels call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, & ierr,ierr2,ierr3,xf_ens,axx,forcing, & maxens3,mconv,rand_clos, & @@ -1903,6 +2116,7 @@ subroutine cu_gf_deep_run( & its,ite, kts,kte, & dicycle,tau_ecmwf,aa1_bl,xf_dicycle) ! +!$acc kernels do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then @@ -1918,11 +2132,14 @@ subroutine cu_gf_deep_run( & endif enddo enddo +!$acc end kernels + 250 continue ! !--- feedback ! if(imid.eq.1 .and. ichoice .le.2)then +!$acc kernels do i=its,itf !-boundary layer qe xff_mid(i,1)=0. @@ -1941,6 +2158,7 @@ subroutine cu_gf_deep_run( & xff_mid(i,2)=min(0.1,.03*zws(i)) endif enddo +!$acc end kernels endif call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, & dellaqc_ens,outt, & @@ -1959,6 +2177,7 @@ subroutine cu_gf_deep_run( & po_cup,qes_cup,pwavo,edto,pwevo,pre,outt,outq) !,outbuoy) k=1 +!$acc kernels do i=its,itf if(ierr(i).eq.0 .and.pre(i).gt.0.) then pre(i)=max(pre(i),0.) @@ -1980,9 +2199,11 @@ subroutine cu_gf_deep_run( & enddo endif enddo +!$acc end kernels ! rain evaporation as in sas ! if(irainevap.eq.1)then +!$acc kernels do i = its,itf rntot(i) = 0. delqev(i) = 0. @@ -1991,8 +2212,10 @@ subroutine cu_gf_deep_run( & rntot(i) = 0. rain=0. if(ierr(i).eq.0)then +!$acc loop independent do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) +!$acc atomic rntot(i) = rntot(i) + rain * xmb(i)* .001 * dtime enddo endif @@ -2003,6 +2226,7 @@ subroutine cu_gf_deep_run( & if(ierr(i).eq.0)then evef = edt(i) * evfact * sig(i)**2 if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef = edt(i) * evfactl * sig(i)**2 +!$acc loop seq do k = ktop(i), 1, -1 rain = pwo(i,k) + edto(i) * pwdo(i,k) rn(i) = rn(i) + rain * xmb(i) * .001 * dtime @@ -2037,8 +2261,10 @@ subroutine cu_gf_deep_run( & ! pre(i)=1000.*rn(i)/dtime endif enddo +!$acc end kernels endif +!$acc kernels do i=its,itf if(ierr(i).eq.0) then if(aeroevap.gt.1)then @@ -2048,9 +2274,12 @@ subroutine cu_gf_deep_run( & endif endif enddo +!$acc end kernels + ! ! since kinetic energy is being dissipated, add heating accordingly (from ecmwf) ! +!$acc kernels do i=its,itf if(ierr(i).eq.0) then dts=0. @@ -2070,7 +2299,7 @@ subroutine cu_gf_deep_run( & endif endif enddo - +!$acc end kernels ! !---------------------------done------------------------------ @@ -2083,7 +2312,7 @@ end subroutine cu_gf_deep_run subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) - +!$acc routine vector ! --- modify a 1-D array of tracer fluxes for the purpose of maintaining ! --- monotonicity (including positive-definiteness) in the tracer field ! --- during tracer transport. @@ -2188,9 +2417,10 @@ subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) / (1.0001*dtovdz(k))) clipout(k)=min(damp,(soln_lo(k)-trmin(k))/max(epsil,totlout(k)) & / (1.0001*dtovdz(k))) - +#ifndef _OPENACC if (NaN(clipin(k))) print *,'(fct1d) error: clipin is NaN, k=',k if (NaN(clipout(k))) print *,'(fct1d) error: clipout is NaN, k=',k +#endif if (clipin(k).lt.0.) then ! print 100,'(fct1d) error: clipin < 0 at k =',k, & @@ -2215,7 +2445,9 @@ subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) end if trflx_out(k)=flx_lo(k)+clipped(k) if (NaN(trflx_out(k))) then +#ifndef _OPENACC print *,'(fct1d) error: trflx_out is NaN, k=',k +#endif error=.true. end if end do @@ -2227,6 +2459,7 @@ subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) !dellac(k)=soln_hi(k) end do +#ifndef _OPENACC if (vrbos .or. error) then ! do k=2,ktop ! write(32,99)k, & @@ -2256,6 +2489,7 @@ subroutine fct1d3 (ktop,n,dt,z,tracr,massflx,trflx_in,dellac,g) ! end do if (error) stop '(fct1d error)' end if +#endif return end subroutine fct1d3 @@ -2277,6 +2511,8 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & real(kind=kind_phys), dimension(its:ite,kts:kte),intent(in) :: po_cup,qo_cup,qes_cup real(kind=kind_phys), dimension(its:ite) ,intent(inout) :: pre real(kind=kind_phys), dimension(its:ite,kts:kte),intent(inout) :: outt,outq !,outbuoy +!$acc declare copyin(ierr,kbcon,psur,xland,pwavo,edto,pwevo,xmb,po_cup,qo_cup,qes_cup) +!$acc declare copy(pre,outt,outq) !real, dimension(its:ite) ,intent(out) :: tot_evap_bcb !real, dimension(its:ite,kts:kte),intent(out) :: evap_bcb,net_prec_bcb @@ -2286,7 +2522,9 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & real(kind=kind_phys) :: RH_cr , del_t,del_q,dp,q_deficit real(kind=kind_phys), dimension(its:ite,kts:kte) :: evap_bcb,net_prec_bcb real(kind=kind_phys), dimension(its:ite) :: tot_evap_bcb +!$acc declare create(evap_bcb,net_prec_bcb,tot_evap_bcb) +!$acc kernels do i=its,itf evap_bcb (i,:)= 0.0 net_prec_bcb(i,:)= 0.0 @@ -2303,6 +2541,7 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & !net_prec_bcb(i,k) = xmb(i)*(pwavo(i)+edto(i)*pwevo(i)) !-- pwevo<0. net_prec_bcb(i,k) = pre(i) +!$acc loop seq do k=kbcon(i)-1, kts, -1 q_deficit = max(0.,(RH_cr*qes_cup(i,k) -qo_cup(i,k))) @@ -2340,6 +2579,7 @@ subroutine rain_evap_below_cloudbase(itf,ktf, its,ite, kts,kte,ierr, & pre(i) = pre(i) - evap_bcb(i,k) enddo enddo +!$acc end kernels end subroutine rain_evap_below_cloudbase @@ -2384,6 +2624,8 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copyin(rho,us,vs,z,p,pw,pwav,pwev,psum2,psumh,edtmax,edtmin,ktop,kbcon) +!$acc declare copyout(edtc,edt) copy(ccn,ierr) ! ! local variables in this routine ! @@ -2392,6 +2634,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & real(kind=kind_phys) einc,pef,pefb,prezk,zkbc real(kind=kind_phys), dimension (its:ite) :: & vshear,sdp,vws +!$acc declare create(vshear,sdp,vws) real(kind=kind_phys) :: prop_c,aeroadd,alpha3,beta3 prop_c=0. !10.386 alpha3 = 0.75 @@ -2405,6 +2648,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & ! ! */ calculate an average wind shear over the depth of the cloud ! +!$acc kernels do i=its,itf edt(i)=0. vws(i)=0. @@ -2480,6 +2724,7 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & if(edtc(i,1).lt.edtmin(i))edtc(i,1)=edtmin(i) endif enddo +!$acc end kernels end subroutine cup_dd_edt @@ -2517,21 +2762,25 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & ,intent (in ) :: & zd,hes_cup,hcd,qes_cup,q_cup,z_cup, & dd_massentr,dd_massdetr,gamma_cup,q,he +!$acc declare copyin(zd,hes_cup,hcd,qes_cup,q_cup,z_cup,dd_massentr,dd_massdetr,gamma_cup,q,he) integer & ,intent (in ) :: & iloop integer, dimension (its:ite) & ,intent (in ) :: & jmin +!$acc declare copyin(jmin) integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) real(kind=kind_phys), dimension (its:ite,kts:kte)& ,intent (out ) :: & qcd,qrcd,pwd real(kind=kind_phys), dimension (its:ite)& ,intent (out ) :: & pwev,bu +!$acc declare copyout(qcd,qrcd,pwd,pwev,bu) character*50 :: ierrc(its:ite) ! ! local variables in this routine @@ -2542,6 +2791,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & real(kind=kind_phys) :: & denom,dh,dz,dqeva +!$acc kernels do i=its,itf bu(i)=0. pwev(i)=0. @@ -2573,6 +2823,7 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz ! bu(i)=dz*dh +!$acc loop seq do ki=jmin(i)-1,1,-1 dz=z_cup(i,ki+1)-z_cup(i,ki) ! qcd(i,ki)=(qcd(i,ki+1)*(1.-.5*cdd(i,ki+1)*dz) & @@ -2617,15 +2868,20 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & if( (pwev(i).eq.0.) .and. (iloop.eq.1))then ! print *,'problem with buoy in cup_dd_moisture',i ierr(i)=7 +#ifndef _OPENACC ierrc(i)="problem with buoy in cup_dd_moisture" +#endif endif if(bu(i).ge.0.and.iloop.eq.1)then ! print *,'problem with buoy in cup_dd_moisture',i ierr(i)=7 +#ifndef _OPENACC ierrc(i)="problem2 with buoy in cup_dd_moisture" +#endif endif endif 100 continue +!$acc end kernels end subroutine cup_dd_moisture @@ -2664,18 +2920,23 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & p,t,q +!$acc declare copyin(p,t,q) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (out ) :: & he,hes,qes +!$acc declare copyout(he,hes,qes) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & z +!$acc declare copy(z) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & psur,z1 +!$acc declare copyin(psur,z1) integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) integer & ,intent (in ) :: & itest @@ -2687,6 +2948,7 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & i,k ! real(kind=kind_phys), dimension (1:2) :: ae,be,ht real(kind=kind_phys), dimension (its:ite,kts:kte) :: tv +!$acc declare create(tv) real(kind=kind_phys) :: tcrit,e,tvbar ! real(kind=kind_phys), external :: satvap ! real(kind=kind_phys) :: satvap @@ -2698,6 +2960,7 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & ! ae(1)=be(1)/273.+alog(610.71) ! be(2)=.622*ht(2)/.286 ! ae(2)=be(2)/273.+alog(610.71) +!$acc parallel loop collapse(2) private(e) do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then @@ -2717,11 +2980,13 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & endif enddo enddo +!$acc end parallel ! !--- z's are calculated with changed h's and q's and t's !--- if itest=2 ! if(itest.eq.1 .or. itest.eq.0)then +!$acc kernels do i=its,itf if(ierr(i).eq.0)then z(i,1)=max(0.,z1(i))-(log(p(i,1))- & @@ -2730,7 +2995,9 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & enddo ! --- calculate heights +!$acc loop seq do k=kts+1,ktf +!$acc loop private(tvbar) do i=its,itf if(ierr(i).eq.0)then tvbar=.5*tv(i,k)+.5*tv(i,k-1) @@ -2739,7 +3006,9 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & endif enddo enddo +!$acc end kernels else if(itest.eq.2)then +!$acc kernels do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then @@ -2748,12 +3017,14 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & endif enddo enddo +!$acc end kernels else if(itest.eq.-1)then endif ! !--- calculate moist static energy - he ! saturated moist static energy - hes ! +!$acc kernels do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then @@ -2763,6 +3034,7 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & endif enddo enddo +!$acc end kernels end subroutine cup_env @@ -2802,15 +3074,19 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & qes,q,he,hes,z,p,t +!$acc declare copyin(qes,q,he,hes,z,p,t) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (out ) :: & qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup +!$acc declare copyout(qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & psur,z1 +!$acc declare copyin(psur,z1) integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) ! ! local variables in this routine ! @@ -2818,7 +3094,7 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & integer :: & i,k - +!$acc kernels do k=kts,ktf do i=its,itf qes_cup(i,k)=0. @@ -2864,7 +3140,7 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & *t_cup(i,1)))*qes_cup(i,1) endif enddo - +!$acc end kernels end subroutine cup_env_clev !>\ingroup cu_gf_deep_group @@ -2911,6 +3187,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 real(kind=kind_phys), dimension (its:ite,1:maxens3) & ,intent (inout ) :: & xf_ens +!$acc declare copy(pr_ens,xf_ens) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & zd,zu,p_cup,zdm @@ -2929,9 +3206,11 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & mconv,axx +!$acc declare copyin(zd,zu,p_cup,zdm,omeg,xaa0,rand_clos,aa1,edt,edtm,mconv,axx) real(kind=kind_phys), dimension (its:ite) & ,intent (inout) :: & aa0,closure_n +!$acc declare copy(aa0,closure_n) real(kind=kind_phys) & ,intent (in ) :: & mbdt @@ -2947,6 +3226,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 integer, dimension (its:ite) & ,intent (inout) :: & ierr,ierr2,ierr3 +!$acc declare copy(k22,kbcon,ktop,ierr,ierr2,ierr3) copyin(xland) integer & ,intent (in ) :: & ichoice @@ -2954,6 +3234,7 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 real(kind=kind_phys), intent(in) , dimension (its:ite) :: aa1_bl,tau_ecmwf real(kind=kind_phys), intent(inout), dimension (its:ite) :: xf_dicycle real(kind=kind_phys), intent(inout), dimension (its:ite,10) :: forcing +!$acc declare copyin(aa1_bl,tau_ecmwf) copy(xf_dicycle,forcing) !- local var real(kind=kind_phys) :: xff_dicycle ! @@ -2974,15 +3255,20 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4 real(kind=kind_phys), dimension (its:ite) :: ens_adj +!$acc declare create(kloc,ens_adj) ! +!$acc kernels ens_adj(:)=1. +!$acc end kernels xff_dicycle = 0. !--- large scale forcing ! +!$acc kernels +!$acc loop private(xff_ens3,xk) do 100 i=its,itf kloc(i)=1 if(ierr(i).eq.0)then @@ -3218,13 +3504,15 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 enddo endif ! ierror 100 continue + !$acc end kernels !- !- diurnal cycle mass flux !- if(dicycle == 1 )then - +!$acc kernels +!$acc loop private(xk) do i=its,itf xf_dicycle(i) = 0. if(ierr(i) /= 0)cycle @@ -3238,9 +3526,11 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 xf_dicycle(i)= xf_ens(i,10)-xf_dicycle(i) enddo +!$acc end kernels else +!$acc kernels xf_dicycle(:) = 0. - +!$acc end kernels endif !--------- @@ -3273,24 +3563,31 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & he_cup,hes_cup,p_cup +!$acc declare copyin(he_cup,hes_cup,p_cup) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & entr_rate,ztexec,zqexec,cap_inc,cap_max +!$acc declare copyin(entr_rate,ztexec,zqexec,cap_inc,cap_max) real(kind=kind_phys), dimension (its:ite) & ,intent (inout ) :: & hkb !,cap_max +!$acc declare copy(hkb) integer, dimension (its:ite) & ,intent (in ) :: & kbmax +!$acc declare copyin(kbmax) integer, dimension (its:ite) & ,intent (inout) :: & kbcon,k22,ierr +!$acc declare copy(kbcon,k22,ierr) integer & ,intent (in ) :: & iloop_in character*50 :: ierrc(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte),intent (in) :: z_cup,heo +!$acc declare copyin(z_cup,heo) integer, dimension (its:ite) :: iloop,start_level +!$acc declare create(iloop,start_level) ! ! local variables in this routine ! @@ -3300,10 +3597,16 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & real(kind=kind_phys) :: & x_add,pbcdif,plus,hetest,dz real(kind=kind_phys), dimension (its:ite,kts:kte) ::hcot +!$acc declare create(hcot) + ! !--- determine the level of convective cloud base - kbcon ! +!$acc kernels iloop(:)=iloop_in +!$acc end kernels + +!$acc parallel loop do 27 i=its,itf kbcon(i)=1 ! @@ -3317,6 +3620,7 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & ! if(iloop_in.eq.5)start_level(i)=kbcon(i) !== including entrainment for hetest hcot(i,1:start_level(i)) = hkb(i) +!$acc loop seq do k=start_level(i)+1,kbmax(i)+3 dz=z_cup(i,k)-z_cup(i,k-1) hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1) & @@ -3331,7 +3635,9 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & if(kbcon(i).gt.kbmax(i)+2)then if(iloop(i).ne.4)then ierr(i)=3 +#ifndef _OPENACC ierrc(i)="could not find reasonable kbcon in cup_kbcon" +#endif endif go to 27 endif @@ -3364,6 +3670,7 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & start_level(i)=k22(i) ! if(iloop_in.eq.5)start_level(i)=kbcon(i) hcot(i,1:start_level(i)) = hkb(i) +!$acc loop seq do k=start_level(i)+1,kbmax(i)+3 dz=z_cup(i,k)-z_cup(i,k-1) @@ -3377,13 +3684,16 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & if(kbcon(i).gt.kbmax(i)+2)then if(iloop(i).ne.4)then ierr(i)=3 +#ifndef _OPENACC ierrc(i)="could not find reasonable kbcon in cup_kbcon" +#endif endif go to 27 endif go to 32 endif 27 continue + !$acc end parallel end subroutine cup_kbcon @@ -3410,27 +3720,33 @@ subroutine cup_maximi(array,ks,ke,maxx,ierr, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & array +!$acc declare copyin(array) integer, dimension (its:ite) & ,intent (in ) :: & ierr,ke +!$acc declare copyin(ierr,ke) integer & ,intent (in ) :: & ks integer, dimension (its:ite) & ,intent (out ) :: & maxx +!$acc declare copyout(maxx) real(kind=kind_phys), dimension (its:ite) :: & x +!$acc declare create(x) real(kind=kind_phys) :: & xar integer :: & i,k +!$acc kernels do 200 i=its,itf maxx(i)=ks if(ierr(i).eq.0)then x(i)=array(i,ks) ! +!$acc loop seq do 100 k=ks,ke(i) xar=array(i,k) if(xar.ge.x(i)) then @@ -3440,6 +3756,7 @@ subroutine cup_maximi(array,ks,ke,maxx,ierr, & 100 continue endif 200 continue + !$acc end kernels end subroutine cup_maximi @@ -3466,23 +3783,29 @@ subroutine cup_minimi(array,ks,kend,kt,ierr, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & array +!$acc declare copyin(array) integer, dimension (its:ite) & ,intent (in ) :: & ierr,ks,kend +!$acc declare copyin(ierr,ks,kend) integer, dimension (its:ite) & ,intent (out ) :: & kt +!$acc declare copyout(kt) real(kind=kind_phys), dimension (its:ite) :: & x +!$acc declare create(x) integer :: & i,k,kstop +!$acc kernels do 200 i=its,itf kt(i)=ks(i) if(ierr(i).eq.0)then x(i)=array(i,ks(i)) kstop=max(ks(i)+1,kend(i)) ! +!$acc loop seq do 100 k=ks(i)+1,kstop if(array(i,k).lt.x(i)) then x(i)=array(i,k) @@ -3491,6 +3814,7 @@ subroutine cup_minimi(array,ks,kend,kt,ierr, & 100 continue endif 200 continue + !$acc end kernels end subroutine cup_minimi @@ -3525,6 +3849,7 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop +!$acc declare copyin(z,zu,gamma_cup,t_cup,dby,kbcon,ktop) ! ! input and output ! @@ -3533,9 +3858,11 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & aa0 +!$acc declare copyout(aa0) ! ! local variables in this routine ! @@ -3545,6 +3872,7 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & real(kind=kind_phys) :: & dz,da ! +!$acc kernels do i=its,itf aa0(i)=0. enddo @@ -3562,6 +3890,7 @@ subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & if(aa0(i).lt.0.)aa0(i)=0. enddo enddo +!$acc end kernels end subroutine cup_up_aa0 @@ -3582,6 +3911,7 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & real(kind=kind_phys), dimension (its:ite ) , & intent(inout ) :: & pret +!$acc declare copy(outq,outt,outqc,outu,outv,q,pret) character *(*), intent (in) :: & name real(kind=kind_phys) & @@ -3601,11 +3931,14 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & names=1. endif scalef=86400. +!$acc kernels +!$acc loop private(qmemf,qmem,icheck) do i=its,itf if(ktop(i) <= 2)cycle icheck=0 qmemf=1. qmem=0. +!$acc loop reduction(min:qmemf) do k=kts,ktop(i) qmem=(outt(i,k))*86400. if(qmem.gt.thresh)then @@ -3633,6 +3966,7 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & enddo pret(i)=pret(i)*qmemf enddo +!$acc end kernels ! return ! ! check whether routine produces negative q's. this can happen, since @@ -3643,9 +3977,12 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & ! return ! write(14,*)'return' thresh=1.e-32 +!$acc kernels +!$acc loop private(qmemf,qmem,icheck) do i=its,itf if(ktop(i) <= 2)cycle qmemf=1. +!$acc loop reduction(min:qmemf) do k=kts,ktop(i) qmem=outq(i,k) if(abs(qmem).gt.0. .and. q(i,k).gt.1.e-6)then @@ -3670,7 +4007,7 @@ subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & enddo pret(i)=pret(i)*qmemf enddo - +!$acc end kernels end subroutine neg_check !>\ingroup cu_gf_deep_group @@ -3744,6 +4081,8 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ierr,ierr2,ierr3 integer, intent(in) :: dicycle real(kind=kind_phys), intent(in), dimension (its:ite) :: xf_dicycle +!$acc declare copyin(zu,pwd,p_cup,sig,xmbm_in,xmbs_in,edt,xff_mid,dellat,dellaqc,dellaq,pw,ktop,xland1,xf_dicycle) +!$acc declare copy(xf_ens,pr_ens,outtem,outq,outqc,pre,xmb,closure_n,ierr,ierr2,ierr3) ! ! local variables in this routine ! @@ -3754,11 +4093,13 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd real(kind=kind_phys), dimension (its:ite) :: & pre2,xmb_ave,pwtot +!$acc declare create(pre2,xmb_ave,pwtot) ! character *(*), intent (in) :: & name ! +!$acc kernels do k=kts,kte do i=its,ite outtem (i,k)=0. @@ -3779,6 +4120,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & enddo endif enddo +!$acc end kernels ! !--- calculate ensemble average mass fluxes ! @@ -3788,10 +4130,12 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & ! !!!!! deep convection !!!!!!!!!! if(imid.eq.0)then +!$acc kernels do i=its,itf if(ierr(i).eq.0)then k=0 xmb_ave(i)=0. +!$acc loop seq do n=1,maxens3 k=k+1 xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) @@ -3825,8 +4169,10 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & endif enddo +!$acc end kernels !!!!! not so deep convection !!!!!!!!!! else ! imid == 1 +!$acc kernels do i=its,itf xmb_ave(i)=0. if(ierr(i).eq.0)then @@ -3836,6 +4182,7 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & xmb_ave(i)=sig(i)*xff_mid(i,ichoice) else if(ichoice.gt.2)then k=0 +!$acc loop seq do n=1,maxens3 k=k+1 xmb_ave(i)=xmb_ave(i)+xf_ens(i,n) @@ -3856,8 +4203,10 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & endif ! dicycle=1,2 endif ! ierr >0 enddo ! i +!$acc end kernels endif ! imid=1 +!$acc kernels do i=its,itf if(ierr(i).eq.0)then dtpw=0. @@ -3870,8 +4219,10 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & PRE(I)=PRE(I)+XMB(I)*dtpw endif enddo +!$acc end kernels return +!$acc kernels do i=its,itf pwtot(i)=0. pre2(i)=0. @@ -3907,10 +4258,12 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & enddo pre(i)=-pre(i)+xmb(i)*pwtot(i) endif +#ifndef _OPENACC 124 format(1x,i3,4e13.4) 125 format(1x,2e13.4) +#endif enddo - +!$acc end kernels end subroutine cup_output_ens_3d !------------------------------------------------------- @@ -3957,6 +4310,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer, dimension (its:ite) & ,intent (in ) :: & kbcon,ktop,k22,xland1 +!$acc declare copyin(p_cup,rho,q,zu,gamma_cup,qe_cup,up_massentr,up_massdetr,dby,qes_cup,z_cup,zqexec,c0,kbcon,ktop,k22,xland1) real(kind=kind_phys), intent (in ) :: & ! HCB ccnclean ! @@ -3968,6 +4322,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer, dimension (its:ite) & ,intent (inout) :: & ierr +!$acc declare copy(ierr) character *(*), intent (in) :: & name ! qc = cloud q (including liquid water) after entrainment @@ -3980,19 +4335,25 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (out ) :: & qc,qrc,pw,clw_all +!$acc declare copy(qc,qrc,pw,clw_all) real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout) :: & c1d +!$acc declare copy(c1d) real(kind=kind_phys), dimension (its:ite,kts:kte) :: & qch,qrcb,pwh,clw_allh,c1d_b,t +!$acc declare create(qch,qrcb,pwh,clw_allh,c1d_b,t) real(kind=kind_phys), dimension (its:ite) :: & pwavh +!$acc declare create(pwavh) real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & pwav,psum,psumh +!$acc declare copyout(pwav,psum,psumh) real(kind=kind_phys), dimension (its:ite) & ,intent (in ) :: & ccn +!$acc declare copyin(ccn) ! ! local variables in this routine ! @@ -4000,6 +4361,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & integer :: & iprop,iall,i,k integer :: start_level(its:ite),kklev(its:ite) +!$acc declare create(start_level,kklev) real(kind=kind_phys) :: & prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,clwdet, & dz,berryc0,q1,berryc @@ -4007,19 +4369,30 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & denom, c0t, c0_iceconv real(kind=kind_phys), dimension (kts:kte) :: & prop_b +!$acc declare create(prop_b) ! + real(kind=kind_phys), parameter:: zero = 0 + logical :: is_mid, is_deep + + is_mid = (name == 'mid') + is_deep = (name == 'deep') + +!$acc kernels prop_b(kts:kte)=0 +!$acc end kernels iall=0 clwdet=0.1 !0.02 c0_iceconv=0.01 c1d_b=c1d bdsp=bdispm + ! !--- no precip for small clouds ! ! if(name.eq.'shallow')then ! c0=0.002 ! endif +!$acc kernels do i=its,itf pwav(i)=0. pwavh(i)=0. @@ -4039,10 +4412,13 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrcb(i,k)=0. enddo enddo +!$acc end kernels + +!$acc parallel loop private(start_level,qaver,k) do i=its,itf if(ierr(i).eq.0)then start_level=k22(i) - call get_cloud_bc(kte,qe_cup (i,1:kte),qaver,k22(i)) + call get_cloud_bc(kte,qe_cup (i,1:kte),qaver,k22(i),zero) qaver = qaver k=start_level(i) qc (i,k)= qaver @@ -4056,7 +4432,10 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! endif enddo +!$acc end parallel + +!$acc kernels do 100 i=its,itf !c0=.004 HCB tuning if(ierr(i).eq.0)then @@ -4064,6 +4443,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & ! below lfc, but maybe above lcl ! ! if(name == "deep" )then +!$acc loop seq do k=k22(i)+1,kbcon(i) if(t(i,k) > 273.16) then c0t = c0(i) @@ -4090,13 +4470,14 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !now do the rest ! kklev(i)=maxloc(zu(i,:),1) +!$acc loop seq do k=kbcon(i)+1,ktop(i) if(t(i,k) > 273.16) then c0t = c0(i) else c0t = c0(i) * exp(c0_iceconv * (t(i,k) - 273.16)) endif - if(name == "mid")c0t=0.004 + if(is_mid)c0t=0.004 denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1) if(denom.lt.1.e-16)then @@ -4138,7 +4519,7 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & qrc(i,k)=max(0.,(qc(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) clw_allh(i,k)=max(0.,qch(i,k)-qrch) qrcb(i,k)=max(0.,(qch(i,k)-qrch)) ! /(1.+c0(i)*dz*zu(i,k)) - if(name == "deep" )then + if(is_deep)then clwdet=0.1 !0.02 ! 05/11/2021 if(k.lt.kklev(i)) clwdet=0. ! 05/05/2021 else @@ -4220,7 +4601,9 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & psum(i)=psum(i)+pw(i,k) ! HCB enddo ! k=kbcon,ktop ! do not include liquid/ice in qc +!$acc loop independent do k=k22(i)+1,ktop(i) +!$acc atomic qc(i,k)=qc(i,k)-qrc(i,k) enddo endif ! ierr @@ -4228,12 +4611,15 @@ subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & !--- integrated normalized ondensate ! 100 continue +!$acc end kernels prop_ave=0. iprop=0 +!$acc parallel loop reduction(+:prop_ave,iprop) do k=kts,kte prop_ave=prop_ave+prop_b(k) if(prop_b(k).gt.0)iprop=iprop+1 enddo +!$acc end parallel iprop=max(iprop,1) end subroutine cup_up_moisture @@ -4241,6 +4627,7 @@ end subroutine cup_up_moisture !-------------------------------------------------------------------- !>\ingroup cu_gf_deep_group real function satvap(temp2) +!$acc routine seq implicit none real(kind=kind_phys) :: temp2, temp, toot, toto, eilog, tsot, & & ewlog, ewlog2, ewlog3, ewlog4 @@ -4266,10 +4653,11 @@ real function satvap(temp2) !-------------------------------------------------------------------- !>\ingroup cu_gf_deep_group subroutine get_cloud_bc(mzp,array,x_aver,k22,add) +!$acc routine seq implicit none integer, intent(in) :: mzp,k22 - real(kind=kind_phys) , intent(in) :: array(mzp) - real(kind=kind_phys) , optional , intent(in) :: add + real(kind=kind_phys) , dimension(:), intent(in) :: array + real(kind=kind_phys) , intent(in) :: add real(kind=kind_phys) , intent(out) :: x_aver integer :: i,local_order_aver,order_aver @@ -4286,7 +4674,7 @@ subroutine get_cloud_bc(mzp,array,x_aver,k22,add) x_aver = x_aver + array(k22-i+1) enddo x_aver = x_aver/float(local_order_aver) - if(present(add)) x_aver = x_aver + add + x_aver = x_aver + add end subroutine get_cloud_bc !======================================================================================== @@ -4301,19 +4689,31 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo,rand_vmas integer, dimension (its:ite),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev integer, dimension (its:ite),intent (inout) :: kbcon,ierr,ktop,ktopdby +!$acc declare copy(entr_rate_2d,zuo,kbcon,ierr,ktop,ktopdby) & +!$acc copyin(p_cup, heo,heso_cup,z_cup,hkbo,rand_vmas,kstabi,k22,kpbl,csum,xland,pmin_lev) + !-local vars real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot +!$acc declare create(hcot) real(kind=kind_phys) :: entr_init,beta_u,dz,dbythresh,dzh2,zustart,zubeg,massent,massdetr real(kind=kind_phys) :: dby(kts:kte),dbm(kts:kte),zux(kts:kte) real(kind=kind_phys) zuh2(40),zh2(40) integer :: kklev,i,kk,kbegin,k,kfinalzu - integer, dimension (its:ite) :: start_level + integer, dimension (its:ite) :: start_level +!$acc declare create(start_level) + logical :: is_deep, is_mid, is_shallow ! zustart=.1 dbythresh= 0.8 !.0.95 ! 0.85, 0.6 if(name == 'shallow' .or. name == 'mid') dbythresh=1. - dby(:)=0. + !dby(:)=0. + + is_deep = (name .eq. 'deep') + is_mid = (name .eq. 'mid') + is_shallow = (name .eq. 'shallow') + +!$acc parallel loop private(beta_u,entr_init,dz,massent,massdetr,zubeg,kklev,kfinalzu,dby,dbm,zux,zuh2,zh2) do i=its,itf if(ierr(i) > 0 )cycle zux(:)=0. @@ -4326,6 +4726,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo zuo(i,start_level(i))=zustart zux(start_level(i))=zustart entr_init=entr_rate_2d(i,kts) +!$acc loop seq do k=start_level(i)+1,kbcon(i) dz=z_cup(i,k)-z_cup(i,k-1) massent=dz*entr_rate_2d(i,k-1)*zuo(i,k-1) @@ -4335,10 +4736,11 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo zux(k)=zuo(i,k) enddo zubeg=zustart !zuo(i,kbcon(i)) - if(name .eq. 'deep')then + if(is_deep)then ktop(i)=0 hcot(i,start_level(i))=hkbo(i) dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1) +!$acc loop seq do k=start_level(i)+1,ktf-2 dz=z_cup(i,k)-z_cup(i,k-1) @@ -4350,6 +4752,7 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo enddo ktopdby(i)=maxloc(dby(:),1) kklev=maxloc(dbm(:),1) +!$acc loop seq do k=maxloc(dby(:),1)+1,ktf-2 if(dby(k).lt.dbythresh*maxval(dby))then kfinalzu=k - 1 @@ -4374,38 +4777,41 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo ! call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"up",ierr(i),start_level(i), & ! call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),kbcon(i), & ! kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i)) - call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"up",ierr(i),k22(i), & + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,1,ierr(i),k22(i), & kfinalzu+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! end deep - if ( name == 'mid' ) then + if ( is_mid ) then if(ktop(i) <= kbcon(i)+2)then ierr(i)=41 ktop(i)= 0 else kfinalzu=ktop(i) ktopdby(i)=ktop(i)+1 - call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"mid",ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) + call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,3, & + ierr(i),k22(i),ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! mid - if ( name == 'shallow' ) then + if ( is_shallow ) then if(ktop(i) <= kbcon(i)+2)then ierr(i)=41 ktop(i)= 0 else kfinalzu=ktop(i) ktopdby(i)=ktop(i)+1 - call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"sh2",ierr(i),k22(i), & + call get_zu_zd_pdf_fim(kbcon(i),p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,2,ierr(i),k22(i), & ktopdby(i)+1,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i)) endif endif ! shal enddo +!$acc end parallel loop end subroutine rates_up_pdf !------------------------------------------------------------------------- !>\ingroup cu_gf_deep_group subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,kb,kt,zu,kts,kte,ktf,max_mass,kpbli,csum,pmin_lev) +!$acc routine vector implicit none ! real(kind=kind_phys), parameter :: beta_deep=1.3,g_beta_deep=0.8974707 @@ -4421,7 +4827,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k real(kind=kind_phys), intent(in) :: p(kts:kte) real(kind=kind_phys) :: trash,beta_deep,zuh(kts:kte),zuh2(1:40) integer, intent(inout) :: ierr - character*(*), intent(in) ::draft + integer, intent(in) ::draft !- local var integer :: k1,kk,k,kb_adj,kpbli_adj,kmax @@ -4431,22 +4837,18 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! very simple lookup tables ! real(kind=kind_phys), dimension(30) :: alpha,g_alpha - data (alpha(k),k=4,27)/3.699999, & + data (alpha(k),k=1,30)/3.699999,3.699999,3.699999,3.699999,& 3.024999,2.559999,2.249999,2.028571,1.862500, & 1.733333,1.630000,1.545454,1.475000,1.415385, & 1.364286,1.320000,1.281250,1.247059,1.216667, & 1.189474,1.165000,1.142857,1.122727,1.104348, & - 1.087500,1.075000,1.075000/ - data (g_alpha(k),k=4,27)/4.170645, & + 1.087500,1.075000,1.075000,1.075000,1.075000,1.075000/ + data (g_alpha(k),k=1,30)/4.170645,4.170645,4.170645,4.170645, & 2.046925 , 1.387837, 1.133003, 1.012418,0.9494680, & 0.9153771,0.8972442,0.8885444,0.8856795,0.8865333, & 0.8897996,0.8946404,0.9005030,0.9070138,0.9139161, & 0.9210315,0.9282347,0.9354376,0.9425780,0.9496124, & - 0.9565111,0.9619183,0.9619183/ - alpha(1:3)=alpha(4) - g_alpha(1:3)=g_alpha(4) - alpha(28:30)=alpha(27) - g_alpha(28:30)=g_alpha(27) + 0.9565111,0.9619183,0.9619183,0.9619183,0.9619183,0.9619183/ !- kb cannot be at 1st level @@ -4454,7 +4856,15 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k zu(:)=0.0 zuh(:)=0.0 kb_adj=max(kb,2) - if(draft == "up") then + +! Dan: replaced draft string with integer +! up = 1 +! sh2 = 2 +! mid = 3 +! down = 4 +! downm = 5 + + if(draft == 1) then lev_start=min(.9,.1+csum*.013) kb_adj=max(kb,2) tunning=max(p(kklev+1),.5*(p(kpbli)+p(kt))) @@ -4495,7 +4905,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4514,9 +4924,10 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! if(p(kt).gt.400.)write(32,122)k,p(k),zu(k),trash endif enddo +#ifndef _OPENACC 122 format(1x,i4,1x,f8.1,1x,f6.2,1x,f6.2) - - elseif(draft == "sh2") then +#endif + elseif(draft == 2) then k=kklev if(kpbli.gt.5)k=kpbli !new nov18 @@ -4553,7 +4964,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1))) if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4566,7 +4977,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! write(32,122)k,p(k),zu(k) enddo - elseif(draft == "mid") then + elseif(draft == 3) then kb_adj=max(kb,2) tunning=.5*(p(kt)+p(kpbli)) !p(kt)+(p(kb_adj)-p(kt))*.9 !*.33 !new nov18 @@ -4602,7 +5013,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k if(zu(kpbli).gt.0.) & zu(kts:min(ktf,kt-1))= zu(kts:min(ktf,kt-1))/zu(kpbli) - do k=maxloc(zu(:),1),1,-1 + do k=my_maxloc1d(zu(:),kte,1),1,-1 if(zu(k).lt.1.e-6)then kb_adj=k+1 exit @@ -4619,7 +5030,7 @@ subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,k ! write(33,122)k,p(k),zu(k) enddo - elseif(draft == "down" .or. draft == "downm") then + elseif(draft == 4 .or. draft == 5) then tunning=p(kb) tunning =min(0.95, (tunning-p(1))/(p(kt)-p(1))) !=.6 @@ -4712,21 +5123,23 @@ subroutine cup_up_aa1bl(aa0,t,tn,q,qo,dtime, & real(kind=kind_phys) :: & dz,da ! +!$acc kernels do i=its,itf aa0(i)=0. enddo do i=its,itf +!$acc loop independent do k=kts,kbcon(i) if(ierr(i).ne.0 ) cycle ! if(k.gt.kbcon(i)) cycle dz = (z_cup (i,k+1)-z_cup (i,k))*g da = dz*(tn(i,k)*(1.+0.608*qo(i,k))-t(i,k)*(1.+0.608*q(i,k)))/dtime - +!$acc atomic aa0(i)=aa0(i)+da enddo enddo - +!$acc end kernels end subroutine cup_up_aa1bl !---------------------------------------------------------------------- @@ -4738,11 +5151,15 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay implicit none integer ,intent (in ) :: itf,ktf,its,ite,kts,kte integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend +!$acc declare copyin(ierr,kstart,kend) integer, dimension (its:ite) :: kend_p3 +!$acc declare create(kend_p3) real(kind=kind_phys), dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup real(kind=kind_phys), dimension (its:ite,kts:kte), intent (out) :: dtempdz integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers +!$acc declare copyin(p_cup,t_cup,z_cup,qo_cup,qeso_cup) +!$acc declare copyout(dtempdz,k_inv_layers) !-local vars real(kind=kind_phys) :: dp,l_mid,l_shal,first_deriv(kts:kte),sec_deriv(kts:kte) integer:: ken,kadd,kj,i,k,ilev,kk,ix,k800,k550,mid,shal @@ -4750,7 +5167,10 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay !-initialize k_inv_layers as undef l_mid=300. l_shal=100. +!$acc kernels k_inv_layers(:,:) = 1 +!$acc end kernels +!$acc parallel loop private(first_deriv,sec_deriv,ilev,ix,k,kadd,ken) do i = its,itf if(ierr(i) == 0)then sec_deriv(:)=0. @@ -4770,6 +5190,7 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay ix=1 k=ilev do while (ilev < kend_p3(i)) !(z_cup(i,ilev)<15000.) +!$acc loop seq do kk=k,kend_p3(i)+2 !k,ktf-2 if(sec_deriv(kk) < sec_deriv(kk+1) .and. & @@ -4786,6 +5207,7 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay !- 2nd criteria kadd=0 ken=maxloc(k_inv_layers(i,:),1) +!$acc loop seq do k=1,ken kk=k_inv_layers(i,k+kadd) if(kk.eq.1)exit @@ -4801,8 +5223,10 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay enddo endif enddo +!$acc end parallel 100 format(1x,16i3) !- find the locations of inversions around 800 and 550 hpa +!$acc parallel loop private(sec_deriv,shal,mid) do i = its,itf if(ierr(i) /= 0) cycle @@ -4827,13 +5251,14 @@ subroutine get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_lay k_inv_layers(i,mid )=k_inv_layers(i,k550) ! this is for mid/congestus convection k_inv_layers(i,mid+1:kte)=-1 enddo - +!$acc end parallel end subroutine get_inversion_layers !----------------------------------------------------------------------------------- !>\ingroup cu_gf_deep_group !> This function calcualtes function deriv3(xx, xi, yi, ni, m) +!$acc routine vector !============================================================================*/ ! evaluate first- or second-order derivatives ! using three-point lagrange interpolation @@ -4863,7 +5288,11 @@ function deriv3(xx, xi, yi, ni, m) ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0 if (xx < xi(1) .or. xx > xi(ni)) then deriv3 = 0.0 +#ifndef _OPENACC stop "problems with finding the 2nd derivative" +#else + return +#endif end if ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i) @@ -4918,9 +5347,10 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte ,draft,kbcon,k22,up_massentru,up_massdetru,lambau) implicit none - character *(*), intent (in) :: draft + integer, intent (in) :: draft integer, intent(in):: itf,ktf, its,ite, kts,kte integer, intent(in) , dimension(its:ite) :: ierr,ktop,kbcon,k22 +!$acc declare copyin(ierr,ktop,kbcon,k22) !real(kind=kind_phys), intent(in), optional , dimension(its:ite):: lambau real(kind=kind_phys), intent(inout), optional , dimension(its:ite):: lambau real(kind=kind_phys), intent(in) , dimension(its:ite,kts:kte) :: zo_cup,zuo @@ -4929,10 +5359,13 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte ,up_massentr, up_massdetr real(kind=kind_phys), intent( out), dimension(its:ite,kts:kte), optional :: & up_massentru,up_massdetru +!$acc declare copy(lambau,cd,entr_rate_2d) copyin(zo_cup,zuo) copyout(up_massentro, up_massdetro,up_massentr, up_massdetr) +!$acc declare copyout(up_massentro, up_massdetro,up_massentr, up_massdetr, up_massentru,up_massdetru) !-- local vars integer :: i,k, incr1,incr2,turn real(kind=kind_phys) :: dz,trash,trash2 +!$acc kernels do k=kts,kte do i=its,ite up_massentro(i,k)=0. @@ -4941,17 +5374,22 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte up_massdetr (i,k)=0. enddo enddo +!$acc end kernels if(present(up_massentru) .and. present(up_massdetru))then +!$acc kernels do k=kts,kte do i=its,ite up_massentru(i,k)=0. up_massdetru(i,k)=0. enddo enddo +!$acc end kernels endif +!$acc parallel loop do i=its,itf if(ierr(i).eq.0)then - + +!$acc loop private(dz) do k=max(2,k22(i)+1),maxloc(zuo(i,:),1) !=> below maximum value zu -> change entrainment dz=zo_cup(i,k)-zo_cup(i,k-1) @@ -4965,6 +5403,7 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte endif if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1)) enddo +!$acc loop private(dz) do k=maxloc(zuo(i,:),1)+1,ktop(i) !=> above maximum value zu -> change detrainment dz=zo_cup(i,k)-zo_cup(i,k-1) @@ -4989,8 +5428,12 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte do k=2,ktf-1 up_massentr (i,k-1)=up_massentro(i,k-1) up_massdetr (i,k-1)=up_massdetro(i,k-1) - enddo - if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'deep')then + enddo +! Dan: draft +! deep = 1 +! shallow = 2 +! mid = 3 + if(present(up_massentru) .and. present(up_massdetru) .and. draft == 1)then !turn=maxloc(zuo(i,:),1) !do k=2,turn ! up_massentru(i,k-1)=up_massentro(i,k-1)+.1*lambau(i)*up_massentro(i,k-1) @@ -5001,12 +5444,12 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) enddo - else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'shallow')then + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 2)then do k=2,ktf-1 up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1) enddo - else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 'mid')then + else if(present(up_massentru) .and. present(up_massdetru) .and. draft == 3)then lambau(i)=0. do k=2,ktf-1 up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1) @@ -5025,6 +5468,7 @@ subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte endif enddo +!$acc end parallel end subroutine get_lateral_massflux !---meltglac------------------------------------------------- !------------------------------------------------------------------------------------ @@ -5036,17 +5480,23 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer integer ,intent (in ) :: itf,ktf, its,ite, kts,kte real(kind=kind_phys), intent (in ), dimension(its:ite,kts:kte) :: tn,po_cup real(kind=kind_phys), intent (inout), dimension(its:ite,kts:kte) :: p_liq_ice,melting_layer +!$acc declare copyin(tn,po_cup) copy(p_liq_ice,melting_layer) integer , intent (in ), dimension(its:ite) :: ierr +!$acc declare copyin(ierr) integer :: i,k real(kind=kind_phys) :: dp - real(kind=kind_phys), dimension(its:ite) :: norm + real(kind=kind_phys), dimension(its:ite) :: norm +!$acc declare create(norm) real(kind=kind_phys), parameter :: t1=276.16 ! hli initialize at the very beginning +!$acc kernels p_liq_ice (:,:) = 1. melting_layer(:,:) = 0. +!$acc end kernels !-- get function of t for partition of total condensate into liq and ice phases. if(melt_glac .and. cumulus == 'deep') then +!$acc kernels do i=its,itf if(ierr(i).eq.0)then do k=kts,ktf @@ -5089,8 +5539,10 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer !do k=kts,ktf do i=its,itf if(ierr(i).eq.0)then +!$acc loop independent do k=kts,ktf-1 dp = 100.*(po_cup(i,k)-po_cup(i,k+1)) +!$acc atomic update norm(i) = norm(i) + melting_layer(i,k)*dp/g enddo endif @@ -5111,10 +5563,12 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer ! !print*,"n=",i,k,norm(i) ! enddo ! enddo - +!$acc end kernels else +!$acc kernels p_liq_ice (:,:) = 1. melting_layer(:,:) = 0. +!$acc end kernels endif end subroutine get_partition_liq_ice @@ -5131,13 +5585,15 @@ subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco real(kind=kind_phys) ,intent (in ), dimension(its:ite,kts:kte) :: tn_cup,po_cup,qrco,pwo & ,pwdo,p_liq_ice,melting_layer real(kind=kind_phys) ,intent (inout), dimension(its:ite,kts:kte) :: melting +!$acc declare copyin(ierr,edto,tn_cup,po_cup,qrco,pwo,pwdo,p_liq_ice,melting_layer,melting) integer :: i,k real(kind=kind_phys) :: dp real(kind=kind_phys), dimension(its:ite) :: norm,total_pwo_solid_phase real(kind=kind_phys), dimension(its:ite,kts:kte) :: pwo_solid_phase,pwo_eff +!$acc declare create(norm,total_pwo_solid_phase,pwo_solid_phase,pwo_eff) if(melt_glac .and. cumulus == 'deep') then - +!$acc kernels !-- set melting mixing ratio to zero for columns that do not have deep convection do i=its,itf if(ierr(i) > 0) melting(i,:) = 0. @@ -5185,10 +5641,12 @@ subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco ! print*,"cons=",i,norm(i),total_pwo_solid_phase(i) ! enddo !-- - +!$acc end kernels else +!$acc kernels !-- no melting allowed in this run melting (:,:) = 0. +!$acc end kernels endif end subroutine get_melting_profile !---meltglac------------------------------------------------- @@ -5203,12 +5661,15 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c real(kind=kind_phys), dimension (its:ite),intent (in) :: hkbo integer, dimension (its:ite),intent (in) :: kstabi,k22,kbcon,kpbl,klcl integer, dimension (its:ite),intent (inout) :: ierr,ktop +!$acc declare copy(entr_rate_2d,zuo,ierr,ktop) copyin(p_cup, heo,heso_cup,z_cup,hkbo,kstabi,k22,kbcon,kpbl,klcl) real(kind=kind_phys), dimension (its:ite,kts:kte) :: hcot +!$acc declare create(hcot) character *(*), intent (in) :: name real(kind=kind_phys) :: dz,dh, dbythresh real(kind=kind_phys) :: dby(kts:kte) integer :: i,k,ipr,kdefi,kstart,kbegzu,kfinalzu integer, dimension (its:ite) :: start_level +!$acc declare create(start_level) integer,parameter :: find_ktop_option = 1 !0=original, 1=new dbythresh=0.8 !0.95 ! the range of this parameter is 0-1, higher => lower @@ -5219,6 +5680,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c dbythresh=1.0 endif ! print*,"================================cumulus=",name; call flush(6) +!$acc parallel loop private(dby,kfinalzu,dz) do i=its,itf kfinalzu=ktf-2 ktop(i)=kfinalzu @@ -5233,7 +5695,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c dby(start_level(i))=(hcot(i,start_level(i))-heso_cup(i,start_level(i)))*dz !print*,'hco1=',start_level(i),kbcon(i),hcot(i,start_level(i))/heso_cup(i,start_level(i)) - +!$acc loop seq do k=start_level(i)+1,ktf-2 dz=z_cup(i,k)-z_cup(i,k-1) @@ -5273,6 +5735,7 @@ subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_c ! endif enddo +!$acc end parallel end subroutine get_cloud_top !------------------------------------------------------------------------------------ diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index d134b7d02..43e82a745 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -7,7 +7,7 @@ module cu_gf_driver ! DH* TODO: replace constants with arguments to cu_gf_driver_run !use physcons , g => con_g, cp => con_cp, xlv => con_hvap, r_v => con_rv use machine , only: kind_phys - use cu_gf_deep, only: cu_gf_deep_run,neg_check,fct1d3 + use cu_gf_deep, only: cu_gf_deep_run,neg_check,autoconv,aeroevap,fct1d3 use cu_gf_sh , only: cu_gf_sh_run implicit none @@ -40,11 +40,14 @@ subroutine cu_gf_driver_init(imfshalcnv, imfshalcnv_gf, imfdeepcnv, & errflg = 0 ! DH* temporary - if (mpirank==mpiroot) then - write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' - write(0,*) ' --- WARNING --- the CCPP Grell Freitas convection scheme is currently under development, use at your own risk --- WARNING ---' - write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' - end if + ! if (mpirank==mpiroot) then + ! write(0,*) ' ----------------------------------------------------------'//& + ! '-------------------------------------------------------------------' + ! write(0,*) ' --- WARNING --- the CCPP Grell Freitas convection scheme is'//& + ! ' currently under development, use at your own risk --- WARNING ---' + ! write(0,*) ' --------------------------------------------------------------------'//& + ! '---------------------------------------------------------' + ! end if ! *DH temporary ! Consistency checks @@ -83,7 +86,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend, & dtend,dtidx,ntqv,ntiw,ntcw,index_of_temperature,index_of_x_wind, & index_of_y_wind,index_of_process_scnv,index_of_process_dcnv, & - ldiag3d,qci_conv,errmsg,errflg) + fhour,fh_dfi_radar,ix_dfi_radar,num_dfi_radar,cap_suppress, & + dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & + errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -98,6 +103,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, parameter :: ichoicem=13 ! 0 2 5 13 integer, parameter :: ichoice_s=3 ! 0 1 2 3 + logical, intent(in) :: do_cap_suppress real(kind=kind_phys), parameter :: aodc0=0.14 real(kind=kind_phys), parameter :: aodreturn=30. real(kind=kind_phys) :: dts,fpi,fp @@ -113,39 +119,58 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& logical, intent(in ) :: ldiag3d real(kind=kind_phys), intent(inout) :: dtend(:,:,:) +!$acc declare copy(dtend) integer, intent(in) :: dtidx(:,:), & index_of_x_wind, index_of_y_wind, index_of_temperature, & index_of_process_scnv, index_of_process_dcnv, ntqv, ntcw, ntiw - +!$acc declare copyin(dtidx) real(kind=kind_phys), dimension( : , : ), intent(in ) :: forcet,forceqv_spechum,w,phil real(kind=kind_phys), dimension( : , : ), intent(inout ) :: t,us,vs real(kind=kind_phys), dimension( : , : ), intent(inout ) :: qci_conv real(kind=kind_phys), dimension( : , : ), intent(out ) :: cnvw_moist,cnvc real(kind=kind_phys), dimension( : , : ), intent(inout ) :: cliw, clcw +!$acc declare copyin(forcet,forceqv_spechum,w,phil) +!$acc declare copy(t,us,vs,qci_conv,cliw, clcw) +!$acc declare copyout(cnvw_moist,cnvc) real(kind=kind_phys), allocatable :: clcw_save(:,:), cliw_save(:,:) + integer, intent(in) :: dfi_radar_max_intervals + real(kind=kind_phys), intent(in) :: fhour, fh_dfi_radar(:) + integer, intent(in) :: num_dfi_radar, ix_dfi_radar(:) + real(kind=kind_phys), intent(in) :: cap_suppress(:,:) +!$acc declare copyin(fh_dfi_radar,ix_dfi_radar,cap_suppress) + integer, dimension (:), intent(out) :: hbot,htop,kcnv integer, dimension (:), intent(in) :: xland real(kind=kind_phys), dimension (:), intent(in) :: pbl +!$acc declare copyout(hbot,htop,kcnv) +!$acc declare copyin(xland,pbl) integer, dimension (im) :: tropics +!$acc declare create(tropics) ! ruc variable real(kind=kind_phys), dimension (:), intent(in) :: hfx2,qfx2,psuri real(kind=kind_phys), dimension (:,:), intent(out) :: ud_mf,dd_mf,dt_mf real(kind=kind_phys), dimension (:), intent(out) :: raincv,cld1d real(kind=kind_phys), dimension (:,:), intent(in) :: t2di,p2di +!$acc declare copyin(hfx2,qfx2,psuri,t2di,p2di) +!$acc declare copyout(ud_mf,dd_mf,dt_mf,raincv,cld1d) ! Specific humidity from FV3 real(kind=kind_phys), dimension (:,:), intent(in) :: qv2di_spechum real(kind=kind_phys), dimension (:,:), intent(inout) :: qv_spechum real(kind=kind_phys), dimension (:), intent(inout) :: aod_gf +!$acc declare copyin(qv2di_spechum) copy(qv_spechum,aod_gf) ! Local water vapor mixing ratios and cloud water mixing ratios real(kind=kind_phys), dimension (im,km) :: qv2di, qv, forceqv, cnvw +!$acc declare create(qv2di, qv, forceqv, cnvw) ! real(kind=kind_phys), dimension(:),intent(in) :: garea +!$acc declare copyin(garea) real(kind=kind_phys), intent(in ) :: dt integer, intent(in ) :: imfshalcnv integer, dimension(:), intent(inout) :: cactiv,cactiv_m +!$acc declare copy(cactiv,cactiv_m) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -174,11 +199,23 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer, dimension (im) :: kbcon, ktop,ierr,ierrs,ierrm,kpbli integer, dimension (im) :: k22s,kbcons,ktops,k22,jmin,jminm integer, dimension (im) :: kbconm,ktopm,k22m +!$acc declare create(k22_shallow,kbcon_shallow,ktop_shallow,rand_mom,rand_vmas, & +!$acc rand_clos,gdc,gdc2,ht,ccn_gf,ccn_m,dx,frhm,frhd, & +!$acc outt,outq,outqc,phh,subm,cupclw,cupclws, & +!$acc dhdt,zu,zus,zd,phf,zum,zdm,outum,outvm, & +!$acc outts,outqs,outqcs,outu,outv,outus,outvs, & +!$acc outtm,outqm,outqcm,submm,cupclwm, & +!$acc cnvwt,cnvwts,cnvwtm,hco,hcdo,zdo,zdd,hcom,hcdom,zdom, & +!$acc tau_ecmwf,edt,edtm,edtd,ter11,aa0,xlandi, & +!$acc pret,prets,pretm,hexec,forcing,forcing2, & +!$acc kbcon, ktop,ierr,ierrs,ierrm,kpbli, & +!$acc k22s,kbcons,ktops,k22,jmin,jminm,kbconm,ktopm,k22m) integer :: iens,ibeg,iend,jbeg,jend,n integer :: ibegh,iendh,jbegh,jendh integer :: ibegc,iendc,jbegc,jendc,kstop real(kind=kind_phys), dimension(im,km) :: rho_dryar +!$acc declare create(rho_dryar) real(kind=kind_phys) :: pten,pqen,paph,zrho,pahfs,pqhfl,zkhvfl,pgeoh integer, parameter :: ipn = 0 @@ -192,6 +229,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), dimension (im) :: z1,psur,cuten,cutens,cutenm real(kind=kind_phys), dimension (im) :: umean,vmean,pmean real(kind=kind_phys), dimension (im) :: xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv +!$acc declare create(qcheck,zo,t2d,q2d,po,p2d,rhoi,clw_ten,tn,qo,tshall,qshall,dz8w,omeg, & +!$acc z1,psur,cuten,cutens,cutenm,umean,vmean,pmean, & +!$acc xmbs,xmbs2,xmb,xmbm,xmb_dumm,mconv) integer :: i,j,k,icldck,ipr,jpr,jpr_deep,ipr_deep,uidx,vidx,tidx,qidx integer :: itf,jtf,ktf,iss,jss,nbegin,nend,cliw_idx,clcw_idx @@ -201,6 +241,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& real(kind=kind_phys), dimension(km) :: massflx,trcflx_in1,clw_in1,po_cup ! real(kind=kind_phys), dimension(km) :: trcflx_in2,clw_in2,clw_ten2 real(kind=kind_phys), dimension (im) :: flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep +!$acc declare create(flux_tun,tun_rad_mid,tun_rad_shall,tun_rad_deep) character*50 :: ierrc(im),ierrcm(im) character*50 :: ierrcs(im) ! ruc variable @@ -208,11 +249,17 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! qfx2 -- latent heat flux (kg/kg m/s), positive upward from sfc ! gf needs them in w/m2. define hfx and qfx after simple unit conversion real(kind=kind_phys), dimension (im) :: hfx,qfx +!$acc declare create(hfx,qfx) real(kind=kind_phys) tem,tem1,tf,tcr,tcrf real(kind=kind_phys) :: cliw_shal,clcw_shal,tem_shal, cliw_both, weight_sum real(kind=kind_phys) :: cliw_deep,clcw_deep,tem_deep, clcw_both integer :: cliw_deep_idx, clcw_deep_idx, cliw_shal_idx, clcw_shal_idx + real(kind=kind_phys) :: cap_suppress_j(im) +!$acc declare create(cap_suppress_j) + integer :: itime, do_cap_suppress_here + logical :: exit_func + !parameter (tf=243.16, tcr=270.16, tcrf=1.0/(tcr-tf)) ! FV3 original !parameter (tf=263.16, tcr=273.16, tcrf=1.0/(tcr-tf)) !parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) @@ -221,6 +268,28 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& errmsg = '' errflg = 0 + if(do_cap_suppress) then +!$acc serial + do itime=1,num_dfi_radar + if(ix_dfi_radar(itime)<1) cycle + if(fhour=fh_dfi_radar(itime+1)) cycle + exit + enddo +!$acc end serial + endif + if(do_cap_suppress .and. itime<=num_dfi_radar) then + do_cap_suppress_here = 1 +!$acc kernels + cap_suppress_j(:) = cap_suppress(:,itime) +!$acc end kernels + else + do_cap_suppress_here = 0 +!$acc kernels + cap_suppress_j(:) = 0 +!$acc end kernels + endif + if(ldiag3d) then if(flag_for_dcnv_generic_tend) then cliw_deep_idx=0 @@ -239,14 +308,18 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& if(cliw_deep_idx>=1 .or. clcw_deep_idx>=1 .or. & cliw_shal_idx>=1 .or. clcw_shal_idx>=1) then allocate(clcw_save(im,km), cliw_save(im,km)) - clcw_save=clcw - cliw_save=cliw +!$acc enter data create(clcw_save,cliw_save) +!$acc kernels + clcw_save(:,:)=clcw(:,:) + cliw_save(:,:)=cliw(:,:) +!$acc end kernels endif endif ! ! Scale specific humidity to dry mixing ratio ! +!$acc kernels ! state in before physics qv2di = qv2di_spechum/(1.0_kind_phys-qv2di_spechum) ! forcing by dynamics, based on state in @@ -258,10 +331,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! these should be coming in from outside ! ! cactiv(:) = 0 -! cactiv_m(:) = 0 rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. +!$acc end kernels ! its=1 ite=im @@ -272,7 +345,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& kts=1 kte=km ktf=kte-1 -! +!$acc kernels +! tropics(:)=0 ! !> - Set tuning constants for radiation coupling @@ -289,6 +363,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! dx for scale awareness ! dx=40075000./float(lonf) ! tscl_kf=dx/25000. +!$acc end kernels if (imfshalcnv == 3) then ishallow_g3 = 1 @@ -315,13 +390,17 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ztq=0. hfm=0. qfm=0. - ud_mf =0. - dd_mf =0. - dt_mf =0. +!$acc kernels + ud_mf(:,:) =0. + dd_mf(:,:) =0. + dt_mf(:,:) =0. tau_ecmwf(:)=0. +!$acc end kernels ! j=1 +!$acc kernels ht(:)=phil(:,1)/g +!$acc loop private(zh) do i=its,ite cld1d(i)=0. zo(i,:)=phil(i,:)/g @@ -331,6 +410,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do k=kts+1,ktf dz8w(i,k)=zo(i,k+1)-zo(i,k) enddo +!$acc loop seq do k=kts+1,ktf zh(k)=zh(k-1)+dz8w(i,k-1) if(zh(k).gt.pbl(i))then @@ -339,7 +419,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& endif enddo enddo +!$acc end kernels +!$acc kernels do i= its,itf forcing(i,:)=0. forcing2(i,:)=0. @@ -407,7 +489,10 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& cuten(:)=0. cutenm(:)=0. cutens(:)=0. +!$acc end kernels ierrc(:)=" " +!$acc kernels + kbcon(:)=0 kbcons(:)=0 @@ -489,7 +574,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& qshall(i,k)=q2d(i,k) enddo enddo +!$acc end kernels 123 format(1x,i2,1x,2(1x,f8.0),1x,2(1x,f8.3),3(1x,e13.5)) +!$acc kernels do i=its,itf do k=kts,kpbli(i) tshall(i,k)=t(i,k) @@ -522,12 +609,16 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! qshall(i,k)=qv(i,k) enddo enddo +!$acc loop collapse(2) independent private(dp) do k= kts+1,ktf-1 do i = its,itf if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then dp=-.5*(p2d(i,k+1)-p2d(i,k-1)) +!$acc atomic umean(i)=umean(i)+us(i,k)*dp +!$acc atomic vmean(i)=vmean(i)+vs(i,k)*dp +!$acc atomic pmean(i)=pmean(i)+dp endif enddo @@ -542,15 +633,18 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& do i = its,itf if(mconv(i).lt.0.)mconv(i)=0. enddo +!$acc end kernels ! !---- call cumulus parameterization ! if(ishallow_g3.eq.1)then +!$acc kernels do i=its,ite ierrs(i)=0 ierrm(i)=0 enddo +!$acc end kernels ! !> - Call shallow: cu_gf_sh_run() ! @@ -566,10 +660,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! dimesnional variables itf,ktf,its,ite, kts,kte,ipr,tropics) - +!$acc kernels do i=its,itf if(xmbs(i).gt.0.)cutens(i)=1. enddo +!$acc end kernels !> - Call neg_check() for GF shallow convection call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) @@ -643,17 +738,16 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! more is possible, talk to developer or ! implement yourself. pattern is expected to be ! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) - ,do_capsuppress,cap_suppress_j & -#endif + ,do_cap_suppress_here,cap_suppress_j & ,k22m & ,jminm,tropics) - +!$acc kernels do i=its,itf do k=kts,ktf qcheck(i,k)=qv(i,k) +outqs(i,k)*dt enddo enddo +!$acc end kernels !> - Call neg_check() for middle GF convection call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) @@ -726,18 +820,18 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! more is possible, talk to developer or ! implement yourself. pattern is expected to be ! betwee -1 and +1 -#if ( wrf_dfi_radar == 1 ) - ,do_capsuppress,cap_suppress_j & -#endif + ,do_cap_suppress_here,cap_suppress_j & ,k22 & ,jmin,tropics) jpr=0 ipr=0 +!$acc kernels do i=its,itf do k=kts,ktf qcheck(i,k)=qv(i,k) +(outqs(i,k)+outqm(i,k))*dt enddo enddo +!$acc end kernels !> - Call neg_check() for deep GF convection call neg_check('deep',ipn,dt,qcheck,outq,outt,outu,outv, & outqc,pret,its,ite,kts,kte,itf,ktf,ktop) @@ -762,6 +856,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! cutenm(i)=0. ! endif ! pret > 0 ! enddo +!$acc kernels do i=its,itf kcnv(i)=0 if(pretm(i).gt.0.)then @@ -786,7 +881,9 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& cuten(i)=0. endif ! pret > 0 enddo +!$acc end kernels ! +!$acc parallel loop private(kstop,dtime_max,massflx,trcflx_in1,clw_in1,po_cup) do i=its,itf massflx(:)=0. trcflx_in1(:)=0. @@ -919,6 +1016,8 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& if(ktop(i).gt.2 .and.pret(i).gt.0.)dt_mf(i,ktop(i)-1)=ud_mf(i,ktop(i)) endif enddo +!$acc end parallel +!$acc kernels do i=its,itf if(pret(i).gt.0.)then cactiv(i)=1 @@ -951,12 +1050,15 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ccn_gf(i)=(aod_gf(i)/0.0027)**(1/0.640) endif enddo +!$acc end kernels 100 continue ! ! Scale dry mixing ratios for water wapor and cloud water to specific humidy / moist mixing ratios ! +!$acc kernels qv_spechum = qv/(1.0_kind_phys+qv) cnvw_moist = cnvw/(1.0_kind_phys+qv) +!$acc end kernels ! ! Diagnostic tendency updates ! @@ -967,21 +1069,28 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& tidx=dtidx(index_of_temperature,index_of_process_scnv) qidx=dtidx(100+ntqv,index_of_process_scnv) if(uidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,uidx) = dtend(:,k,uidx) + cutens(:)*outus(:,k) * dt enddo +!$acc end kernels endif if(vidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,vidx) = dtend(:,k,vidx) + cutens(:)*outvs(:,k) * dt enddo +!$acc end kernels endif if(tidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,tidx) = dtend(:,k,tidx) + cutens(:)*outts(:,k) * dt enddo +!$acc end kernels endif if(qidx>=1) then +!$acc kernels do k=kts,ktf do i=its,itf tem = cutens(i)*outqs(i,k)* dt @@ -989,6 +1098,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& dtend(i,k,qidx) = dtend(i,k,qidx) + tem enddo enddo +!$acc end kernels endif endif if((ideep.eq.1. .or. imid_gf.eq.1) .and. .not.flag_for_dcnv_generic_tend) then @@ -996,23 +1106,30 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& vidx=dtidx(index_of_y_wind,index_of_process_dcnv) tidx=dtidx(index_of_temperature,index_of_process_dcnv) if(uidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,uidx) = dtend(:,k,uidx) + (cuten*outu(:,k)+cutenm*outum(:,k)) * dt enddo +!$acc end kernels endif if(vidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,vidx) = dtend(:,k,vidx) + (cuten*outv(:,k)+cutenm*outvm(:,k)) * dt enddo +!$acc end kernels endif if(tidx>=1) then +!$acc kernels do k=kts,ktf dtend(:,k,tidx) = dtend(:,k,tidx) + (cuten*outt(:,k)+cutenm*outtm(:,k)) * dt enddo +!$acc end kernels endif qidx=dtidx(100+ntqv,index_of_process_dcnv) if(qidx>=1) then +!$acc kernels do k=kts,ktf do i=its,itf tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt @@ -1020,9 +1137,11 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& dtend(i,k,qidx) = dtend(i,k,qidx) + tem enddo enddo +!$acc end kernels endif endif if(allocated(clcw_save)) then +!$acc parallel loop collapse(2) private(tem_shal,tem_deep,tem,tem1,weight_sum,cliw_both,clcw_both) do k=kts,ktf do i=its,itf tem_shal = dt*(outqcs(i,k)*cutens(i)+outqcm(i,k)*cutenm(i)) @@ -1055,6 +1174,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& endif enddo enddo +!$acc end parallel endif endif end subroutine cu_gf_driver_run diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 3a54a9ecc..311a9cb3e 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -58,9 +58,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -486,6 +486,13 @@ dimensions = () type = integer intent = in +[dfi_radar_max_intervals] + standard_name = maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = maximum allowed number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in [ldiag3d] standard_name = flag_for_diagnostics_3D long_name = flag for 3d diagnostic fields @@ -501,6 +508,51 @@ type = real kind = kind_phys intent = inout +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[do_cap_suppress] + standard_name = flag_for_radar_derived_convection_suppression + long_name = flag for radar-derived convection suppression + units = flag + dimensions = () + type = logical + intent = in +[fh_dfi_radar] + standard_name = forecast_lead_times_bounding_radar_derived_temperature_or_convection_suppression_intervals + long_name = forecast lead times bounding radar derived temperature or convection suppression intervals + units = h + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals_plus_one) + type = real + kind = kind_phys + intent = in +[ix_dfi_radar] + standard_name = indices_with_radar_derived_temperature_or_convection_suppression_data + long_name = indices with radar derived temperature or convection suppression data + units = index + dimensions = (maximum_number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = integer + intent = in +[num_dfi_radar] + standard_name = number_of_radar_derived_temperature_or_convection_suppression_intervals + long_name = number of time ranges with radar-derived microphysics temperature tendencies or radar-derived convection suppression + units = count + dimensions = () + type = integer + intent = in +[cap_suppress] + standard_name = radar_derived_convection_suppression + long_name = radar-derived convection suppression + units = unitless + dimensions = (horizontal_loop_extent,number_of_radar_derived_temperature_or_convection_suppression_intervals) + type = real + kind = kind_phys + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -510,9 +562,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cu_gf_driver_post.F90 b/physics/cu_gf_driver_post.F90 index eab5eefd6..b9fafc4df 100644 --- a/physics/cu_gf_driver_post.F90 +++ b/physics/cu_gf_driver_post.F90 @@ -37,6 +37,7 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, co real(kind_phys), intent(out) :: conv_act(:) real(kind_phys), intent(out) :: conv_act_m(:) character(len=*), intent(out) :: errmsg +!$acc declare copyin(t,q,cactiv,cactiv_m) copyout(prevst,prevsq,conv_act,conv_act_m) integer, intent(out) :: errflg ! Local variables @@ -46,6 +47,7 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, co errmsg = '' errflg = 0 +!$acc kernels prevst(:,:) = t(:,:) prevsq(:,:) = q(:,:) @@ -61,6 +63,7 @@ subroutine cu_gf_driver_post_run (im, t, q, prevst, prevsq, cactiv, cactiv_m, co conv_act_m(i)=0.0 endif enddo +!$acc end kernels end subroutine cu_gf_driver_post_run diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta index c3d3e897c..b50c2ab40 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/cu_gf_driver_post.meta @@ -85,9 +85,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cu_gf_driver_pre.F90 b/physics/cu_gf_driver_pre.F90 index 4d4ae9162..58dc0414a 100644 --- a/physics/cu_gf_driver_pre.F90 +++ b/physics/cu_gf_driver_pre.F90 @@ -37,12 +37,15 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, real(kind_phys), intent(in) :: q(:,:) real(kind_phys), intent(in) :: prevst(:,:) real(kind_phys), intent(in) :: prevsq(:,:) +!$acc declare copyin(t,q,prevst,prevsq) real(kind_phys), intent(out) :: forcet(:,:) real(kind_phys), intent(out) :: forceq(:,:) integer, intent(out) :: cactiv(:) integer, intent(out) :: cactiv_m(:) +!$acc declare copyout(forcet,forceq,cactiv,cactiv_m) real(kind_phys), intent(in) :: conv_act(:) real(kind_phys), intent(in) :: conv_act_m(:) +!$acc declare copyin(conv_act,conv_act_m) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -57,21 +60,29 @@ subroutine cu_gf_driver_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, ! are read from the restart files beforehand, same ! for conv_act. if(flag_init .and. .not.flag_restart) then +!$acc kernels forcet(:,:)=0.0 forceq(:,:)=0.0 +!$acc end kernels else dtdyn=3600.0*(fhour)/kdt if(dtp > dtdyn) then +!$acc kernels forcet(:,:)=(t(:,:) - prevst(:,:))/dtp forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp +!$acc end kernels else +!$acc kernels forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn +!$acc end kernels endif endif +!$acc kernels cactiv(:)=nint(conv_act(:)) cactiv_m(:)=nint(conv_act_m(:)) +!$acc end kernels end subroutine cu_gf_driver_pre_run diff --git a/physics/cu_gf_driver_pre.meta b/physics/cu_gf_driver_pre.meta index c587939bd..7fd66d19b 100644 --- a/physics/cu_gf_driver_pre.meta +++ b/physics/cu_gf_driver_pre.meta @@ -131,9 +131,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cu_gf_sh.F90 b/physics/cu_gf_sh.F90 index e30ca95bc..b9a723856 100644 --- a/physics/cu_gf_sh.F90 +++ b/physics/cu_gf_sh.F90 @@ -91,6 +91,7 @@ subroutine cu_gf_sh_run ( & real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (inout ) :: & cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv +!$acc declare copy(cnvwt,outt,outq,outqc,cupclw,zuo,outu,outv) real(kind=kind_phys), dimension (its:ite) & ,intent (out ) :: & xmb_out @@ -103,6 +104,7 @@ subroutine cu_gf_sh_run ( & integer, dimension (its:ite) & ,intent (in ) :: & kpbl,tropics +!$acc declare copyout(xmb_out,kbcon,ktop,k22) copyin(kpbl,tropics) copy(ierr) ! ! basic environmental input includes a flag (ierr) to turn off ! convection for this call only and at that particular gridpoint @@ -120,6 +122,7 @@ subroutine cu_gf_sh_run ( & real(kind=kind_phys) & ,intent (in ) :: & dtime,tcrit +!$acc declare copyin(t,po,tn,dhdt,rho,us,vs) copy(q,qo) copyin(xland,z1,psur,hfx,qfx) copyin(dtime,tcrit) ! !***************** the following are your basic environmental ! variables. they carry a "_cup" if they are @@ -179,6 +182,19 @@ subroutine cu_gf_sh_run ( & cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup +!$acc declare create( & +!$acc entr_rate_2d,he,hes,qes,z, & +!$acc heo,heso,qeso,zo, & +!$acc xhe,xhes,xqes,xz,xt,xq, & +!$acc qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup, & +!$acc qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup, & +!$acc tn_cup, & +!$acc xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup, & +!$acc xt_cup,dby,hc,zu, & +!$acc dbyo,qco,pwo,hco,qrco, & +!$acc dbyt,xdby,xhc,xzu, & +!$acc cd,dellah,dellaq,dellat,dellaqc,uc,vc,dellu,dellv,u_cup,v_cup) + ! aa0 cloud work function for downdraft ! aa0 = cloud work function without forcing effects ! aa1 = cloud work function with forcing effects @@ -192,6 +208,13 @@ subroutine cu_gf_sh_run ( & cap_max_increment,lambau integer, dimension (its:ite) :: & kstabi,xland1,kbmax,ktopx +!$acc declare create( & +!$acc zws,ztexec,zqexec,pre,aa1,aa0,xaa0,hkb, & +!$acc flux_tun,hkbo,xhkb, & +!$acc rand_vmas,xmbmax,xmb, & +!$acc cap_max,entr_rate, & +!$acc cap_max_increment,lambau, & +!$acc kstabi,xland1,kbmax,ktopx) integer :: & kstart,i,k,ki @@ -205,15 +228,24 @@ subroutine cu_gf_sh_run ( & character*50 :: ierrc(its:ite) real(kind=kind_phys), dimension (its:ite,kts:kte) :: & up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru +!$acc declare create(up_massentr,up_massdetr,up_massentro,up_massdetro,up_massentru,up_massdetru) real(kind=kind_phys) :: c_up,x_add,qaver,dts,fp,fpi real(kind=kind_phys), dimension (its:ite,kts:kte) :: c1d,dtempdz integer, dimension (its:ite,kts:kte) :: k_inv_layers integer, dimension (its:ite) :: start_level, pmin_lev +!$acc declare create(c1d,dtempdz,k_inv_layers,start_level, pmin_lev) + + real(kind=kind_phys), parameter :: zero = 0 + +!$acc kernels start_level(:)=0 rand_vmas(:)=0. - flux_tun=fluxtune + flux_tun(:)=fluxtune lambau(:)=2. c1d(:,:)=0. +!$acc end kernels + +!$acc kernels do i=its,itf xland1(i)=int(xland(i)+.001) ! 1. ktopx(i)=0 @@ -224,9 +256,13 @@ subroutine cu_gf_sh_run ( & pre(i)=0. xmb_out(i)=0. cap_max_increment(i)=25. - ierrc(i)=" " entr_rate(i) = 1.e-3 !9.e-5 ! 1.75e-3 ! 1.2e-3 ! .2/50. enddo +!$acc end kernels + + do i=its,itf + ierrc(i)=" " + enddo ! !--- initial entrainment rate (these may be changed later on in the !--- program @@ -235,6 +271,7 @@ subroutine cu_gf_sh_run ( & ! !--- initial detrainmentrates ! +!$acc kernels do k=kts,ktf do i=its,itf up_massentro(i,k)=0. @@ -250,6 +287,7 @@ subroutine cu_gf_sh_run ( & cupclw(i,k)=0. enddo enddo +!$acc end kernels ! !--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft ! @@ -259,6 +297,7 @@ subroutine cu_gf_sh_run ( & !--- maximum depth (mb) of capping !--- inversion (larger cap = no convection) ! +!$acc kernels cap_maxs=175. do i=its,itf kbmax(i)=1 @@ -292,7 +331,7 @@ subroutine cu_gf_sh_run ( & zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct enddo - +!$acc end kernels ! !> - Determin max height(m) above ground where updraft air can originate ! @@ -322,6 +361,8 @@ subroutine cu_gf_sh_run ( & ierr,z1, & itf,ktf, & its,ite, kts,kte) + +!$acc kernels do i=its,itf if(ierr(i).eq.0)then u_cup(i,kts)=us(i,kts) @@ -336,6 +377,7 @@ subroutine cu_gf_sh_run ( & do i=its,itf if(ierr(i).eq.0)then ! +!$acc loop seq do k=kts,ktf if(zo_cup(i,k).gt.zkbmax+z1(i))then kbmax(i)=k @@ -347,12 +389,14 @@ subroutine cu_gf_sh_run ( & kbmax(i)=min(kbmax(i),ktf/2) endif enddo +!$acc end kernels ! ! ! !> - Determine level with highest moist static energy content (\p k22) ! +!$acc parallel loop do 36 i=its,itf if(kpbl(i).gt.3)cap_max(i)=po_cup(i,kpbl(i)) if(ierr(i) == 0)then @@ -360,17 +404,21 @@ subroutine cu_gf_sh_run ( & k22(i)=max(2,k22(i)) if(k22(i).gt.kbmax(i))then ierr(i)=2 +#ifndef _OPENACC ierrc(i)="could not find k22" +#endif ktop(i)=0 k22(i)=0 kbcon(i)=0 endif endif 36 continue +!$acc end parallel ! !> - Call get_cloud_bc() and cup_kbcon() to determine the level of !! convective cloud base (\p kbcon) ! +!$acc parallel loop private(x_add) do i=its,itf if(ierr(i).eq.0)then x_add = xlv*zqexec(i)+cp*ztexec(i) @@ -378,13 +426,17 @@ subroutine cu_gf_sh_run ( & call get_cloud_bc(kte,heo_cup(i,1:kte),hkbo(i),k22(i),x_add) endif ! ierr enddo +!$acc end parallel !joe-georg and saulo's new idea: + +!$acc kernels do i=its,itf do k=kts,ktf dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k) enddo enddo +!$acc end kernels call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, & @@ -403,6 +455,7 @@ subroutine cu_gf_sh_run ( & kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte) ! ! +!$acc parallel loop private(frh,kstart,x_add) do i=its,itf entr_rate_2d(i,:)=entr_rate(i) if(ierr(i) == 0)then @@ -438,9 +491,11 @@ subroutine cu_gf_sh_run ( & endif endif enddo +!$acc end parallel !> - Call rates_up_pdf() to get normalized mass flux profile call rates_up_pdf(rand_vmas,ipr,'shallow',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopx,kbcon,pmin_lev) +!$acc kernels do i=its,itf if(ierr(i).eq.0)then ! do k=maxloc(zuo(i,:),1),1,-1 ! ktop(i)-1,1,-1 @@ -451,22 +506,26 @@ subroutine cu_gf_sh_run ( & ! endif ! enddo if(k22(i).gt.1)then +!$acc loop independent do k=1,k22(i)-1 zuo(i,k)=0. zu (i,k)=0. xzu(i,k)=0. enddo endif +!$acc loop seq do k=maxloc(zuo(i,:),1),ktop(i) if(zuo(i,k).lt.1.e-6)then ktop(i)=k-1 exit endif enddo +!$acc loop independent do k=k22(i),ktop(i) xzu(i,k)= zuo(i,k) zu(i,k)= zuo(i,k) enddo +!$acc loop independent do k=ktop(i)+1,ktf zuo(i,k)=0. zu (i,k)=0. @@ -475,14 +534,15 @@ subroutine cu_gf_sh_run ( & k22(i)=max(2,k22(i)) endif enddo +!$acc end kernels ! !> - Call get_lateral_massflux() to calculate mass entrainment and detrainment ! call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & - ,'shallow',kbcon,k22,up_massentru,up_massdetru,lambau) - + ,2,kbcon,k22,up_massentru,up_massdetru,lambau) +!$acc kernels do k=kts,ktf do i=its,itf hc(i,k)=0. @@ -507,11 +567,15 @@ subroutine cu_gf_sh_run ( & hc(i,k)=hkb(i) hco(i,k)=hkbo(i) enddo +!$acc end kernels ! ! + +!$acc parallel loop private(ki,qaver,k,trash,trash2,dz,dp) do 42 i=its,itf dbyt(i,:)=0. if(ierr(i) /= 0) cycle +!$acc loop seq do k=start_level(i)+1,ktop(i) hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ & up_massentr(i,k-1)*he(i,k-1)) / & @@ -547,16 +611,20 @@ subroutine cu_gf_sh_run ( & if(ktop(i).lt.kbcon(i)+1)then ierr(i)=5 +#ifndef _OPENACC ierrc(i)='ktop is less than kbcon+1' +#endif go to 42 endif if(ktop(i).gt.ktf-2)then ierr(i)=5 +#ifndef _OPENACC ierrc(i)="ktop is larger than ktf-2" +#endif go to 42 endif ! - call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i)) + call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i),zero) qaver = qaver + zqexec(i) do k=1,start_level(i)-1 qco (i,k)= qo_cup(i,k) @@ -564,6 +632,7 @@ subroutine cu_gf_sh_run ( & k=start_level(i) qco (i,k)= qaver ! +!$acc loop seq do k=start_level(i)+1,ktop(i) trash=qeso_cup(i,k)+(1./xlv)*(gammao_cup(i,k) & /(1.+gammao_cup(i,k)))*dbyo(i,k) @@ -593,15 +662,21 @@ subroutine cu_gf_sh_run ( & enddo trash=0. trash2=0. +!$acc loop independent do k=k22(i)+1,ktop(i) dp=100.*(po_cup(i,k)-po_cup(i,k+1)) cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp +!$acc atomic trash2=trash2+entr_rate_2d(i,k) +!$acc atomic qco(i,k)=qco(i,k)-qrco(i,k) enddo +!$acc loop independent do k=k22(i)+1,max(kbcon(i),k22(i)+1) +!$acc atomic trash=trash+entr_rate_2d(i,k) enddo +!$acc loop independent do k=ktop(i)+1,ktf-1 hc (i,k)=hes_cup (i,k) hco (i,k)=heso_cup(i,k) @@ -616,6 +691,7 @@ subroutine cu_gf_sh_run ( & zuo (i,k)=0. enddo 42 continue +!$acc end parallel ! !--- calculate workfunctions for updrafts ! @@ -626,14 +702,18 @@ subroutine cu_gf_sh_run ( & call cup_up_aa0(aa1,zo,zuo,dbyo,gammao_cup,tn_cup, & kbcon,ktop,ierr, & itf,ktf, its,ite, kts,kte) +!$acc kernels do i=its,itf if(ierr(i) == 0)then if(aa1(i) <= 0.)then ierr(i)=17 +#ifndef _OPENACC ierrc(i)="cloud work function zero" +#endif endif endif enddo +!$acc end kernels endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -643,6 +723,7 @@ subroutine cu_gf_sh_run ( & ! !--- 1. in bottom layer ! +!$acc kernels do k=kts,kte do i=its,itf dellah(i,k)=0. @@ -652,6 +733,7 @@ subroutine cu_gf_sh_run ( & dellv (i,k)=0. enddo enddo +!$acc end kernels ! !---------------------------------------------- cloud level ktop ! @@ -692,6 +774,8 @@ subroutine cu_gf_sh_run ( & ! !- - - - - - - - - - - - - - - - - - - - - - - - model level 1 trash2=0. +!$acc kernels +!$acc loop independent do i=its,itf if(ierr(i).eq.0)then dp=100.*(po_cup(i,1)-po_cup(i,2)) @@ -706,10 +790,12 @@ subroutine cu_gf_sh_run ( & entup=up_massentro(i,k) detup=up_massdetro(i,k) totmas=detup-entup+zuo(i,k+1)-zuo(i,k) +#ifndef _OPENACC if(abs(totmas).gt.1.e-6)then write(0,*)'*********************',i,k,totmas write(0,*)k22(i),kbcon(i),ktop(i) endif +#endif dp=100.*(po_cup(i,k)-po_cup(i,k+1)) dellah(i,k) =-(zuo(i,k+1)*(hco(i,k+1)-heo_cup(i,k+1) )- & zuo(i,k )*(hco(i,k )-heo_cup(i,k ) ))*g/dp @@ -741,12 +827,13 @@ subroutine cu_gf_sh_run ( & enddo endif enddo +!$acc end kernels ! !--- using dellas, calculate changed environmental profiles ! mbdt=.5 !3.e-4 - +!$acc kernels do k=kts,ktf do i=its,itf dellat(i,k)=0. @@ -767,6 +854,7 @@ subroutine cu_gf_sh_run ( & xt(i,ktf)=tn(i,ktf) endif enddo +!$acc end kernels ! ! if(make_calc_for_xk) then @@ -788,12 +876,16 @@ subroutine cu_gf_sh_run ( & ! ! !**************************** static control +!$acc kernels do k=kts,ktf do i=its,itf xhc(i,k)=0. xdby(i,k)=0. enddo enddo +!$acc end kernels + +!$acc parallel loop private(x_add) do i=its,itf if(ierr(i).eq.0)then x_add = xlv*zqexec(i)+cp*ztexec(i) @@ -805,17 +897,21 @@ subroutine cu_gf_sh_run ( & xhc(i,k)=xhkb(i) endif !ierr enddo +!$acc end parallel ! ! +!$acc kernels do i=its,itf if(ierr(i).eq.0)then xzu(i,1:ktf)=zuo(i,1:ktf) +!$acc loop seq do k=start_level(i)+1,ktop(i) xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ & up_massentro(i,k-1)*xhe(i,k-1)) / & (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)) xdby(i,k)=xhc(i,k)-xhes_cup(i,k) enddo +!$acc loop independent do k=ktop(i)+1,ktf xhc (i,k)=xhes_cup(i,k) xdby(i,k)=0. @@ -823,6 +919,7 @@ subroutine cu_gf_sh_run ( & enddo endif enddo +!$acc end kernels ! !--- workfunctions for updraft @@ -837,6 +934,8 @@ subroutine cu_gf_sh_run ( & ! ! now for shallow forcing ! +!$acc kernels +!$acc loop private(xff_shal) do i=its,itf xmb(i)=0. xff_shal(1:3)=0. @@ -870,7 +969,9 @@ subroutine cu_gf_sh_run ( & if(ichoice > 0)xmb(i)=min(xmbmax(i),xff_shal(ichoice)) if(xmb(i) <= 0.)then ierr(i)=21 +#ifndef _OPENACC ierrc(i)="21" +#endif endif endif if(ierr(i).ne.0)then @@ -889,10 +990,12 @@ subroutine cu_gf_sh_run ( & ! final tendencies ! pre(i)=0. +!$acc loop independent do k=2,ktop(i) outt (i,k)= dellat (i,k)*xmb(i) outq (i,k)= dellaq (i,k)*xmb(i) outqc(i,k)= dellaqc(i,k)*xmb(i) +!$acc atomic pre (i) = pre(i)+pwo(i,k)*xmb(i) enddo outt (i,1)= dellat (i,1)*xmb(i) @@ -928,6 +1031,7 @@ subroutine cu_gf_sh_run ( & endif endif enddo +!$acc end kernels ! ! done shallow !--------------------------done------------------------------ diff --git a/physics/cu_ntiedtke.meta b/physics/cu_ntiedtke.meta index 68a9827c8..dded8fb20 100644 --- a/physics/cu_ntiedtke.meta +++ b/physics/cu_ntiedtke.meta @@ -58,9 +58,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -319,9 +319,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cu_ntiedtke_post.meta b/physics/cu_ntiedtke_post.meta index 4d83bf57c..703d32b90 100644 --- a/physics/cu_ntiedtke_post.meta +++ b/physics/cu_ntiedtke_post.meta @@ -48,9 +48,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/cu_ntiedtke_pre.meta b/physics/cu_ntiedtke_pre.meta index 5b162041a..ccb9b7f48 100644 --- a/physics/cu_ntiedtke_pre.meta +++ b/physics/cu_ntiedtke_pre.meta @@ -101,9 +101,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 122d6a8e1..8df27a3c2 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -630,9 +630,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index d2d435e4c..7fea98b13 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -218,7 +218,8 @@ subroutine drag_suite_run( & & do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & & dtend, dtidx, index_of_process_orographic_gwd, & & index_of_temperature, index_of_x_wind, & - & index_of_y_wind, ldiag3d, errmsg, errflg) + & index_of_y_wind, ldiag3d, & + & spp_wts_gwd, spp_gwd, errmsg, errflg) ! ******************************************************************** ! -----> I M P L E M E N T A T I O N V E R S I O N <---------- @@ -365,6 +366,11 @@ subroutine drag_suite_run( & real(kind=kind_phys), dimension(im,km) :: zl ! = PHIL/g !SPP + real(kind=kind_phys), dimension(im) :: var_stoch, varss_stoch, & + varmax_ss_stoch, varmax_fd_stoch + real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) + integer, intent(in) :: spp_gwd + real(kind=kind_phys), dimension(im) :: rstoch !Output: @@ -595,6 +601,23 @@ subroutine drag_suite_run( & endif enddo +! SPP, if spp_gwd is 0, no perturbations are applied. +if ( spp_gwd==1 ) then + do i = its,im + var_stoch(i) = var(i) + var(i)*0.75*spp_wts_gwd(i,1) + varss_stoch(i) = varss(i) + varss(i)*0.75*spp_wts_gwd(i,1) + varmax_ss_stoch(i) = varmax_ss + varmax_ss*0.75*spp_wts_gwd(i,1) + varmax_fd_stoch(i) = varmax_fd + varmax_fd*0.75*spp_wts_gwd(i,1) + enddo +else + do i = its,im + var_stoch(i) = var(i) + varss_stoch(i) = varss(i) + varmax_ss_stoch(i) = varmax_ss + varmax_fd_stoch(i) = varmax_fd + enddo +endif + !--- calculate length of grid for flow-blocking drag ! do i=1,im @@ -711,7 +734,7 @@ subroutine drag_suite_run( & ! determine reference level: maximum of 2*var and pbl heights ! do i = its,im - zlowtop(i) = 2. * var(i) + zlowtop(i) = 2. * var_stoch(i) enddo ! do i = its,im @@ -867,7 +890,7 @@ subroutine drag_suite_run( & ! ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 - ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 + ldrag(i) = ldrag(i) .or. var_stoch(i) .le. 0.0 ! ! set all ri low level values to the low level value ! @@ -877,7 +900,7 @@ subroutine drag_suite_run( & ! if (.not.ldrag(i)) then bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * 2. * var(i) * od(i) + fr(i) = bnv(i) * rulow(i) * 2. * var_stoch(i) * od(i) fr(i) = min(fr(i),frmax) xn(i) = ubar(i) * rulow(i) yn(i) = vbar(i) * rulow(i) @@ -961,7 +984,7 @@ subroutine drag_suite_run( & exit ENDIF enddo - if((xland(i)-1.5).le.0. .and. 2.*varss(i).le.hpbl(i))then + if((xland(i)-1.5).le.0. .and. 2.*varss_stoch(i).le.hpbl(i))then if(br1(i).gt.0. .and. thvx(i,kpbl2)-thvx(i,kts) > 0.)then cleff_ss = sqrt(dxy(i)**2 + dxyp(i)**2) ! WRF ! cleff_ss = 3. * max(dx(i),cleff_ss) @@ -980,8 +1003,8 @@ subroutine drag_suite_run( & !tauwavex0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*u1(i,kpbl(i)) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,kpbl2) !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,3) - var_temp = MIN(varss(i),varmax_ss) + & - MAX(0.,beta_ss*(varss(i)-varmax_ss)) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch(i))) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavex0=var_temp2*u1(i,kvar)/(1.+var_temp2*deltim) @@ -995,8 +1018,8 @@ subroutine drag_suite_run( & !tauwavey0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*v1(i,kpbl(i)) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,kpbl2) !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,3) - var_temp = MIN(varss(i),varmax_ss) + & - MAX(0.,beta_ss*(varss(i)-varmax_ss)) + var_temp = MIN(varss_stoch(i),varmax_ss_stoch(i)) + & + MAX(0.,beta_ss*(varss_stoch(i)-varmax_ss_stoch(i))) ! Note: This is a semi-implicit treatment of the time differencing var_temp2 = 0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar) ! this is greater than zero tauwavey0=var_temp2*v1(i,kvar)/(1.+var_temp2*deltim) @@ -1060,8 +1083,8 @@ subroutine drag_suite_run( & IF ((xland(i)-1.5) .le. 0.) then !(IH*kflt**n1)**-1 = (0.00102*0.00035**-1.9)**-1 = 0.00026615161 - var_temp = MIN(varss(i),varmax_fd) + & - MAX(0.,beta_fd*(varss(i)-varmax_fd)) + var_temp = MIN(varss_stoch(i),varmax_fd_stoch(i)) + & + MAX(0.,beta_fd*(varss_stoch(i)-varmax_fd_stoch(i))) var_temp = MIN(var_temp, 250.) a1=0.00026615161*var_temp**2 ! a1=0.00026615161*MIN(varss(i),varmax)**2 @@ -1069,7 +1092,7 @@ subroutine drag_suite_run( & ! k1**(n1-n2) = 0.003**(-1.9 - -2.8) = 0.003**0.9 = 0.005363 a2=a1*0.005363 ! Revise e-folding height based on PBL height and topographic std. dev. -- M. Toy 3/12/2018 - H_efold = max(2*varss(i),hpbl(i)) + H_efold = max(2*varss_stoch(i),hpbl(i)) H_efold = min(H_efold,1500.) DO k=kts,km wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index ba9d4050d..8de3610f5 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -624,6 +624,21 @@ dimensions = () type = logical intent = in +[spp_wts_gwd] + standard_name = spp_weights_for_gravity_wave_drag_scheme + long_name = spp weights for gravity wave drag scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_gwd] + standard_name = control_for_gravity_wave_drag_spp_perturbations + long_name = control for gravity wave drag spp perturbations + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -633,9 +648,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 2855aa026..7ed80d866 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -16,9 +16,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -36,9 +36,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -306,9 +306,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/gcm_shoc.meta b/physics/gcm_shoc.meta index d22e51e6a..984c6aec5 100644 --- a/physics/gcm_shoc.meta +++ b/physics/gcm_shoc.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -400,9 +400,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/get_prs_fv3.meta b/physics/get_prs_fv3.meta index 90630a255..4e893b45c 100644 --- a/physics/get_prs_fv3.meta +++ b/physics/get_prs_fv3.meta @@ -86,9 +86,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -174,9 +174,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/gfdl_cloud_microphys.meta b/physics/gfdl_cloud_microphys.meta index 6f6b1d47f..5e752b473 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/gfdl_cloud_microphys.meta @@ -81,9 +81,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -101,9 +101,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -472,9 +472,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/gfdl_fv_sat_adj.meta b/physics/gfdl_fv_sat_adj.meta index 8eece5a9c..5cdc96358 100644 --- a/physics/gfdl_fv_sat_adj.meta +++ b/physics/gfdl_fv_sat_adj.meta @@ -74,9 +74,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -94,9 +94,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -431,9 +431,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/gfdl_sfc_layer.meta b/physics/gfdl_sfc_layer.meta index 228ab4bca..f1c7a4ce2 100644 --- a/physics/gfdl_sfc_layer.meta +++ b/physics/gfdl_sfc_layer.meta @@ -58,9 +58,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -721,9 +721,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/gscond.meta b/physics/gscond.meta index e46b73618..4c5fd02c3 100644 --- a/physics/gscond.meta +++ b/physics/gscond.meta @@ -37,9 +37,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -298,9 +298,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/gwdc.meta b/physics/gwdc.meta index 2e8076bca..e61559e92 100644 --- a/physics/gwdc.meta +++ b/physics/gwdc.meta @@ -132,9 +132,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -165,9 +165,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -409,9 +409,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -596,9 +596,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/gwdps.f b/physics/gwdps.f index 285bdf67c..12b2fefa0 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -323,7 +323,7 @@ subroutine gwdps_run( & real(kind=kind_phys) wk(IM) real(kind=kind_phys) bnv2lm(IM,KM),PE(IM),EK(IM),ZBK(IM),UP(IM) real(kind=kind_phys) DB(IM,KM),ANG(IM,KM),UDS(IM,KM) - real(kind=kind_phys) ZLEN, DBTMP, Rtrm, PHIANG, CDmb, DBIM, ZR + real(kind=kind_phys) ZLEN, Rtrm, PHIANG, CDmb, DBIM, ZR, cdmbo4 real(kind=kind_phys) ENG0, ENG1 ! ! Some constants @@ -382,13 +382,13 @@ subroutine gwdps_run( & real(kind=kind_phys) BNV2(IM,KM), TAUP(IM,KM+1), ri_n(IM,KM) & &, TAUD(IM,KM), RO(IM,KM), VTK(IM,KM) & &, VTJ(IM,KM), SCOR(IM), VELCO(IM,KM-1) & - &, bnv2bar(im) + &, bnv2bar(im), cdsigohp(im) ! ! real(kind=kind_phys) VELKO(KM-1) integer kref(IM), kint(im), iwk(im), ipt(im) ! for lm mtn blocking integer iwklm(im) -! integer kreflm(IM), iwklm(im) +! integer kreflm(IM), iwklm(im) integer idxzb(im), ktrial, klevm1 ! real(kind=kind_phys) gor, gocp, fv, gr2, bnv, fr & @@ -397,7 +397,7 @@ subroutine gwdps_run( & &, rdelks, efact, coefm, gfobnv, onebg & &, scork, rscor, hd, fro, rim, sira & &, dtaux, dtauy, pkp1log, pklog & - &, cosang, sinang, cos2a, sin2a + &, cosang, sinang, cos2a, sin2a, oneocpdt ! integer kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1,kbpsm1 & &, kmps, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, npr, kmll @@ -413,11 +413,12 @@ subroutine gwdps_run( & ! cdmb = 192.0/float(IMX) cdmb = 4.0 * 192.0/float(IMX) if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) + cdmbo4 = 0.25 * cdmb ! npr = 0 DO I = 1, IM - DUSFC(I) = 0. - DVSFC(I) = 0. + DUSFC(I) = 0. + DVSFC(I) = 0. ENDDO ! DO K = 1, KM @@ -428,12 +429,13 @@ subroutine gwdps_run( & ENDDO ENDDO ! - RDI = 1.0 / RD - onebg = 1.0 / g - GOR = G/RD - GR2 = G*GOR - GOCP = G/CP - FV = RV/RD - 1 + RDI = 1.0 / RD + onebg = 1.0 / g + GOR = G/RD + GR2 = G*GOR + GOCP = G/CP + FV = RV/RD - 1 + oneocpdt = 1.0 / (cp*deltim) ! ! NCNT = 0 KMM1 = KM - 1 @@ -441,17 +443,17 @@ subroutine gwdps_run( & LCAP = KM LCAPP1 = LCAP + 1 ! + RDXZB(:) = 0 ! IF ( NMTVR == 14) then ! ---- for lm and gwd calculation points - RDXZB(:) = 0 ipt = 0 npt = 0 DO I = 1,IM IF (elvmax(i) > HMINMT .and. hprime(i) > hpmin) then - npt = npt + 1 - ipt(npt) = i - if (ipr == i) npr = npt + npt = npt + 1 + ipt(npt) = i +! if (lprnt .and. ipr == i) npr = npt ENDIF ENDDO IF (npt == 0) RETURN ! No gwd/mb calculation done! @@ -488,7 +490,8 @@ subroutine gwdps_run( & ! DO I = 1, npt j = ipt(i) - ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) + ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) + cdsigohp(i) = cdmbo4 * sigma(j) / hprime(j) ENDDO ! DO K = 1,KMLL @@ -626,8 +629,8 @@ subroutine gwdps_run( & ! --- Wind projected on the line perpendicular to mtn range, U(Zb(K)). ! --- kenetic energy is at the layer Zb ! --- THETA ranges from -+90deg |_ to the mtn "largest topo variations" - UP(I) = UDS(I,K) * cos(ANG(I,K)) - EK(I) = 0.5 * UP(I) * UP(I) + UP(I) = UDS(I,K) * cos(ANG(I,K)) + EK(I) = 0.5 * UP(I) * UP(I) ! --- Dividing Stream lime is found when PE =exceeds EK. IF (PE(I) >= EK(I)) THEN @@ -732,9 +735,8 @@ subroutine gwdps_run( & !! where \f$C_{d}\f$ is a specified constant, \f$\sigma\f$ is the !! orographic slope. - DBTMP = 0.25 * CDmb * ZR * sigma(J) * - & MAX(cosANG, gamma(J)*sinANG) * ZLEN / hprime(J) - DB(I,K) = DBTMP * UDS(I,K) + DB(i,k) = CDsigohp(i) * ZR * RO(i,k) * ZLEN + & * MAX(cosANG, gamma(J)*sinANG) * uds(i,k) ! ! if(lprnt .and. i .eq. npr) then ! print *,' in gwdps_lmi.f 10 npt=',npt,i,j,idxzb(i) @@ -770,7 +772,6 @@ subroutine gwdps_run( & ! do i=1,npt IDXZB(i) = 0 - RDXZB(i) = 0. enddo ENDIF ! @@ -884,9 +885,9 @@ subroutine gwdps_run( & ! ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! Mean RO below kref if (k < kref(i)-1) then - RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) + RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) else - RDELKS = (PRSL(J,K)-PRSI(J,K+1)) * DELKS(I) + RDELKS = (PRSL(J,K)-PRSI(J,K+1)) * DELKS(I) endif BNV2bar(I) = BNV2bar(I) + BNV2(I,K) * RDELKS ENDIF @@ -1126,9 +1127,9 @@ subroutine gwdps_run( & !!\f] !! see eq.(4.6) in Kim and Arakawa (1995) \cite kim_and_arakawa_1995. - TEM2 = SQRT(ri_n(I,K)) - TEM = 1. + TEM2 * FRO - RIM = ri_n(I,K) * (1.-FRO) / (TEM * TEM) + TEM2 = SQRT(ri_n(I,K)) + TEM = 1. + TEM2 * FRO + RIM = ri_n(I,K) * (1.-FRO) / (TEM * TEM) ! ! CHECK STABILITY TO EMPLOY THE 'SATURATION HYPOTHESIS' ! OF LINDZEN (1981) EXCEPT AT TROPOSPHERIC DOWNSTREAM REGIONS @@ -1168,7 +1169,7 @@ subroutine gwdps_run( & ! taup(i,km+1) = taup(i,km) ! ENDDO ! - IF(LCAP .LE. KM) THEN + IF(LCAP <= KM) THEN DO KLCAP = LCAPP1, KM+1 DO I = 1,npt SIRA = PRSI(ipt(I),KLCAP) / PRSI(ipt(I),LCAP) @@ -1209,7 +1210,7 @@ subroutine gwdps_run( & ENDDO ENDDO ! -! if(lprnt .and. npr .gt. 0) then +! if(lprnt .and. npr > 0) then ! print *,' before A=',A(npr,:) ! print *,' before B=',B(npr,:) ! endif @@ -1218,6 +1219,7 @@ subroutine gwdps_run( & !! - Below the dividing streamline height (k < idxzb), mountain !! blocking(\f$D_{b}\f$) is applied. !! - Otherwise (k>= idxzb), orographic GWD (\f$\tau\f$) is applied. + DO K = 1,KM DO I = 1,npt J = ipt(i) @@ -1225,30 +1227,35 @@ subroutine gwdps_run( & DTAUX = TAUD(I,K) * XN(I) DTAUY = TAUD(I,K) * YN(I) ENG0 = 0.5*(U1(j,K)*U1(j,K)+V1(J,K)*V1(J,K)) -! --- lm mb (*j*) changes overwrite GWD - if ( K < IDXZB(I) .AND. IDXZB(I) /= 0 ) then - DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) - A(J,K) = - DBIM * V1(J,K) + A(J,K) - B(J,K) = - DBIM * U1(J,K) + B(J,K) - ENG1 = ENG0*(1.0-DBIM*DELTIM)*(1.0-DBIM*DELTIM) -! if ( ABS(DBIM * U1(J,K)) .gt. .01 ) + + if (K < IDXZB(I)) then ! --- lm mb (*j*) changes overwrite GWD + ! --------------------------------------- + DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) + A(J,K) = - DBIM * V1(J,K) + A(J,K) + B(J,K) = - DBIM * U1(J,K) + B(J,K) + ENG1 = ENG0*(1.0-DBIM*DELTIM)*(1.0-DBIM*DELTIM) + +! if ( ABS(DBIM * U1(J,K)) > .01 ) ! & print *,' in gwdps_lmi.f KDT=',KDT,I,K,DB(I,K), ! & dbim,idxzb(I),U1(J,K),V1(J,K),me - DUSFC(J) = DUSFC(J) - DBIM * U1(J,K) * DEL(J,K) - DVSFC(J) = DVSFC(J) - DBIM * V1(J,K) * DEL(J,K) - else -! - A(J,K) = DTAUY + A(J,K) - B(J,K) = DTAUX + B(J,K) - ENG1 = 0.5*( - & (U1(J,K)+DTAUX*DELTIM)*(U1(J,K)+DTAUX*DELTIM) - & + (V1(J,K)+DTAUY*DELTIM)*(V1(J,K)+DTAUY*DELTIM)) - DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) - DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) + + tem1 = DBIM * DEL(J,K) + DUSFC(J) = DUSFC(J) - tem1 * U1(J,K) + DVSFC(J) = DVSFC(J) - tem1 * V1(J,K) + else ! orographic GWD applied + ! ---------------------- + A(J,K) = DTAUY + A(J,K) + B(J,K) = DTAUX + B(J,K) + tem1 = U1(J,K) + DTAUX*DELTIM + tem2 = V1(J,K) + DTAUY*DELTIM + ENG1 = 0.5 * (tem1*tem1+tem2*tem2) + DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) + DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) endif - C(J,K) = C(J,K) + max(ENG0-ENG1,0.)/CP/DELTIM + C(J,K) = C(J,K) + max(ENG0-ENG1,0.) * oneocpdt ENDDO ENDDO + ! if (lprnt) then ! print *,' in gwdps_lm.f after A=',A(ipr,:) ! print *,' in gwdps_lm.f after B=',B(ipr,:) @@ -1256,8 +1263,8 @@ subroutine gwdps_run( & ! endif DO I = 1,npt - J = ipt(i) -! TEM = (-1.E3/G) + J = ipt(i) +! TEM = (-1.E3/G) DUSFC(J) = - onebg * DUSFC(J) DVSFC(J) = - onebg * DVSFC(J) ENDDO @@ -1310,4 +1317,4 @@ end subroutine gwdps_run subroutine gwdps_finalize() end subroutine gwdps_finalize - end module gwdps \ No newline at end of file + end module gwdps diff --git a/physics/gwdps.meta b/physics/gwdps.meta index e483354df..3ce1c5b74 100644 --- a/physics/gwdps.meta +++ b/physics/gwdps.meta @@ -319,9 +319,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/h2ophys.meta b/physics/h2ophys.meta index 759666baf..afe50bda1 100644 --- a/physics/h2ophys.meta +++ b/physics/h2ophys.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -118,9 +118,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/m_micro.meta b/physics/m_micro.meta index e202f7b74..99ebb591f 100644 --- a/physics/m_micro.meta +++ b/physics/m_micro.meta @@ -289,9 +289,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -835,9 +835,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/m_micro_interstitial.meta b/physics/m_micro_interstitial.meta index 031ebbe5a..c7c8a23fd 100644 --- a/physics/m_micro_interstitial.meta +++ b/physics/m_micro_interstitial.meta @@ -250,9 +250,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -440,9 +440,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index d9a236c29..6f7a055b8 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -240,9 +240,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index dde143c4d..bca005bc9 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -16,20 +16,20 @@ !! This version:https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ !! !! \version 2 history: Sep 2011: Development begun. -!!\n Feb 2013: Added of prognostic precipitation. -!!\n Aug 2015: Published and released version +!!\n Feb 2013: Added of prognostic precipitation. +!!\n Aug 2015: Published and released version !! !! Contributions from: Sean Santos, Peter Caldwell, Xiaohong Liu and Steve Ghan !! !! - Anning Cheng adopted mg2 for FV3GFS 9/29/2017 -!!\n add GMAO ice conversion and Liu et. al liquid water +!!\n add GMAO ice conversion and Liu et. al liquid water !!\n conversion in 10/12/2017 !! !! - Anning showed promising results for FV3GFS on 10/15/2017 !! - S. Moorthi - Oct/Nov 2017 - optimized the MG2 code !! - S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit !! - S. Moorthi - Feb 2018 - updated to MG3 - modified graupel sedimentation -!! other modifications to eliminate blowup. +!! other modifications to eliminate blowup. !! - S. Moorthi - Mar 2018 - fixed a few bugs and added option to run as MG2 !! - S. Moorthi - Oct,29,2018 - change nlb from nlev/3 to levels with p/ps < 0.05 (nlball) !! @@ -1162,7 +1162,7 @@ subroutine micro_mg_tend ( & qsfm(i,k) = qsatfac(i,k) enddo enddo - end if + endif ! if (lprnt) write(0,*)' cldm=',cldm(1,nlev-20:nlev) ! if (lprnt) write(0,*)' liqcldf=',liqcldf(1,nlev-20:nlev) @@ -1234,8 +1234,8 @@ subroutine micro_mg_tend ( & ! esl(i,k) = qsfm(i,k) * esl(i,k) relhum(i,k) = max(zero, min(q(i,k)/max(qvl(i,k), qsmall), two)) - end do - end do + enddo + enddo !=============================================== @@ -1590,7 +1590,7 @@ subroutine micro_mg_tend ( & mnuccd = zero end where - end if + endif !============================================================================= @@ -1628,11 +1628,11 @@ subroutine micro_mg_tend ( & ns(i,k) = max(ns(i,k) - ninstsm(i,k), zero) qr(i,k) = max(qr(i,k) + minstsm(i,k), zero) nr(i,k) = max(nr(i,k) + ninstsm(i,k), zero) - end if - end if + endif + endif - end do - end do + enddo + enddo ! if (lprnt) write(0,*)' tlat1=',tlat(1,:)*deltat ! if (lprnt) write(0,*)' qg1=',qg(1,:) @@ -1670,11 +1670,11 @@ subroutine micro_mg_tend ( & ng(i,k) = max(ng(i,k) - ninstgm(i,k), zero) qr(i,k) = max(qr(i,k) + minstgm(i,k), zero) nr(i,k) = max(nr(i,k) + ninstgm(i,k), zero) - end if - end if + endif + endif - end do - end do + enddo + enddo endif ! if (lprnt) write(0,*)' tlat1g=',tlat(1,:)*deltat @@ -1719,10 +1719,10 @@ subroutine micro_mg_tend ( & end if !--ag - end if - end if - end do - end do + endif + endif + enddo + enddo ! if (lprnt) then ! write(0,*)' tlat2=',tlat(1,:)*deltat @@ -1750,11 +1750,11 @@ subroutine micro_mg_tend ( & ! specify droplet concentration if (nccons) then ncic(i,k) = ncnst * rhoinv(i,k) - end if + endif else qcic(i,k) = zero ncic(i,k) = zero - end if + endif ! if (qi(i,k) >= qsmall .and. icldm(i,k) > mincld) then if (qi(i,k) >= qsmall) then @@ -1766,14 +1766,14 @@ subroutine micro_mg_tend ( & ! switch for specification of cloud ice number if (nicons) then niic(i,k) = ninst * rhoinv(i,k) - end if + endif else qiic(i,k) = zero niic(i,k) = zero - end if + endif - end do - end do + enddo + enddo !======================================================================== @@ -1802,12 +1802,12 @@ subroutine micro_mg_tend ( & ! then leave precip_frac as cloud fraction at current level if (k /= 1) then !++ag -! where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall .or. qg(:,k-1) >= qsmall) +! where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall .or. qg(:,k-1) >= qsmall) !--ag where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) precip_frac(:,k) = max(precip_frac(:,k-1), precip_frac(:,k)) end where - end if + endif endif @@ -1916,13 +1916,13 @@ subroutine micro_mg_tend ( & else call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) - end if + endif !else ! Add in the particles that we have already converted to snow, and ! don't do any further autoconversion of ice. !prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) !nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) - end if + endif ! note, currently we don't have this ! inside the do_cldice block, should be changed later @@ -2125,7 +2125,7 @@ subroutine micro_mg_tend ( & !mnudep(:,k) = zero !end where - end if + endif else do i=1,mgncol @@ -2136,7 +2136,7 @@ subroutine micro_mg_tend ( & mnudep(i,k) = zero nnudep(i,k) = zero enddo - end if + endif call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & nsagg(:,k), mgncol) @@ -2150,7 +2150,7 @@ subroutine micro_mg_tend ( & else nsacwi(:,k) = zero msacwi(:,k) = zero - end if + endif call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & @@ -2175,7 +2175,7 @@ subroutine micro_mg_tend ( & else prai(:,k) = zero nprai(:,k) = zero - end if + endif !++ag Moved below graupel conditional, now two different versions ! if (.not. (do_hail .or. do_graupel)) then @@ -2223,9 +2223,9 @@ subroutine micro_mg_tend ( & ! all ql is removed (which is handled elsewhere) !in fact, nothing in this entire file makes nsubc nonzero. nsubc(i,k) = zero - end do + enddo - end if !do_cldice + endif !do_cldice !---PMC 12/3/12 !++ag Process rate calls for graupel here. @@ -2337,7 +2337,7 @@ subroutine micro_mg_tend ( & pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) - end if ! end do_graupel/hail loop + endif ! end do_graupel/hail loop !--ag do i=1,mgncol @@ -2382,7 +2382,7 @@ subroutine micro_mg_tend ( & qcrat(i,k) = ratio else qcrat(i,k) = one - end if + endif ! if(lprnt) write(0,*)' bergs2=',bergs(1,k),' k=',k,' ratio=',ratio @@ -2391,9 +2391,9 @@ subroutine micro_mg_tend ( & !deposition for the remaining frac of the timestep. if (qc(i,k) >= qsmall) then vap_dep(i,k) = vap_dep(i,k) * (one-qcrat(i,k)) - end if + endif - end do + enddo do i=1,mgncol @@ -2419,10 +2419,10 @@ subroutine micro_mg_tend ( & dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) mnuccd(i,k) = dum*dum1 vap_dep(i,k) = dum - mnuccd(i,k) - end if - end if + endif + endif - end do + enddo do i=1,mgncol @@ -2492,9 +2492,9 @@ subroutine micro_mg_tend ( & pracs(i,k) = ratio * pracs(i,k) mnuccr(i,k) = ratio * mnuccr(i,k) mnuccri(i,k) = ratio * mnuccri(i,k) - end if + endif - end do + enddo do i=1,mgncol @@ -2507,9 +2507,9 @@ subroutine micro_mg_tend ( & nsubr(i,k) = dum*nr(i,k) * oneodt else nsubr(i,k) = zero - end if + endif - end do + enddo do i=1,mgncol @@ -2535,9 +2535,9 @@ subroutine micro_mg_tend ( & nnuccr(i,k) = ratio * nnuccr(i,k) nsubr(i,k) = ratio * nsubr(i,k) nnuccri(i,k) = ratio * nnuccri(i,k) - end if + endif - end do + enddo if (do_cldice) then @@ -2569,11 +2569,11 @@ subroutine micro_mg_tend ( & prci(i,k) = ratio * prci(i,k) prai(i,k) = ratio * prai(i,k) ice_sublim(i,k) = ratio * ice_sublim(i,k) - end if + endif - end do + enddo - end if + endif if (do_cldice) then @@ -2585,7 +2585,7 @@ subroutine micro_mg_tend ( & tmpfrz = nnuccc(i,k) else tmpfrz = zero - end if + endif !++ag dum1 = (nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k) ! dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k) & @@ -2601,11 +2601,11 @@ subroutine micro_mg_tend ( & nprci(i,k) = ratio * nprci(i,k) nprai(i,k) = ratio * nprai(i,k) nsubi(i,k) = ratio * nsubi(i,k) - end if + endif - end do + enddo - end if + endif do i=1,mgncol @@ -2648,9 +2648,9 @@ subroutine micro_mg_tend ( & ! ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm ! prds(i,k) = ratio * prds(i,k) -! end if +! endif - end do + enddo do i=1,mgncol @@ -2678,7 +2678,7 @@ subroutine micro_mg_tend ( & ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm nscng(i,k) = ratio * nscng(i,k) ngracs(i,k) = ratio * ngracs(i,k) - end if + endif else dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)) @@ -2692,7 +2692,7 @@ subroutine micro_mg_tend ( & nsubs(i,k) = ratio * nsubs(i,k) nsagg(i,k) = ratio * nsagg(i,k) - end do + enddo !++ag Graupel Conservation Checks !------------------------------------------------------------------- @@ -2714,13 +2714,13 @@ subroutine micro_mg_tend ( & prdg(i,k) = ratio * prdg(i,k) - end if + endif - end do + enddo ! conservation of graupel number: not needed, no sinks !------------------------------------------------------------------- - end if + endif !--ag @@ -2801,10 +2801,10 @@ subroutine micro_mg_tend ( & dum1 = one - dum1 - dum2 - dum3 !--ag ice_sublim(i,k) = dum*dum1*oneodt - end if - end if + endif + endif - end do + enddo ! Big "administration" loop enforces conservation, updates variables ! that accumulate over substeps, and sets output variables. @@ -2902,7 +2902,7 @@ subroutine micro_mg_tend ( & qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - end if + endif !--ag @@ -2938,7 +2938,7 @@ subroutine micro_mg_tend ( & else prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+ & (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - end if + endif ! following are used to calculate 1st order conversion rate of cloud water ! to rain and snow (1/s), for later use in aerosol wet removal routine @@ -3013,7 +3013,7 @@ subroutine micro_mg_tend ( & + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & + (nsubi(i,k)-nprci(i,k)-nprai(i,k))*icldm(i,k) & + (nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k) - end if + endif if(do_graupel.or.do_hail) then ! nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & @@ -3030,7 +3030,7 @@ subroutine micro_mg_tend ( & nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & + nprci(i,k)*icldm(i,k) - end if + endif ! nrtend(i,k) = nrtend(i,k) + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & ! - nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) @@ -3047,9 +3047,9 @@ subroutine micro_mg_tend ( & if (do_cldice .and. nitend(i,k) > zero .and. ni(i,k)+nitend(i,k)*deltat > nimax(i,k)) then nitend(i,k) = max(zero, (nimax(i,k)-ni(i,k))*oneodt) - end if + endif - end do + enddo ! End of "administration" loop @@ -3298,7 +3298,7 @@ subroutine micro_mg_tend ( & else fi(i,k) = zero fni(i,k)= zero - end if + endif ! fallspeed for rain @@ -3318,7 +3318,7 @@ subroutine micro_mg_tend ( & else fr(i,k) = zero fnr(i,k) = zero - end if + endif ! fallspeed for snow @@ -3337,7 +3337,7 @@ subroutine micro_mg_tend ( & else fs(i,k) = zero fns(i,k) = zero - end if + endif if (do_graupel .or. do_hail) then !++ag @@ -3359,7 +3359,7 @@ subroutine micro_mg_tend ( & else fg(i,k) = zero fng(i,k) = zero - end if + endif endif ! redefine dummy variables - sedimentation is calculated over grid-scale @@ -3386,7 +3386,7 @@ subroutine micro_mg_tend ( & if (dumg(i,k) < qsmall) dumng(i,k) = zero enddo - end do !!! vertical loop + enddo !!! vertical loop do k=1,nlev do i=1,mgncol @@ -3488,8 +3488,8 @@ subroutine micro_mg_tend ( & prect(i) = prect(i) + falouti(nlev) * (tx3*0.001_r8) preci(i) = preci(i) + falouti(nlev) * (tx3*0.001_r8) - end do - end if + enddo + endif ! if (lprnt) write(0,*)' tlat4=',tlat(1,:)*deltat ! calculate number of split time steps to ensure courant stability criteria @@ -3559,7 +3559,7 @@ subroutine micro_mg_tend ( & tlat(i,k) = tlat(i,k) - dum2 * xxlv lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 ! Liquid condensate flux here - end do + enddo prect(i) = prect(i) + faloutc(nlev) * (tx3*0.001_r8) @@ -3629,11 +3629,11 @@ subroutine micro_mg_tend ( & faloutnr(k) = fnr(i,k) * dumnr(i,k) rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 ! Rain Flux - end do + enddo prect(i) = prect(i) + faloutr(nlev) * (tx3*0.001_r8) - end do + enddo ! if (lprnt) write(0,*)' prectaftrain=',prect(i),' preci=',preci(i) @@ -3698,7 +3698,7 @@ subroutine micro_mg_tend ( & prect(i) = prect(i) + falouts(nlev) * (tx3*0.001_r8) preci(i) = preci(i) + falouts(nlev) * (tx3*0.001_r8) - end do !! nstep loop + enddo !! nstep loop ! if (lprnt) write(0,*)' prectaftssno=',prect(i),' preci=',preci(i) ! if (lprnt) write(0,*)' qgtnd1=',qgtend(1,:) @@ -3761,7 +3761,7 @@ subroutine micro_mg_tend ( & faloutng(k) = fng(i,k) * dumng(i,k) gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux - end do + enddo ! units below are m/s ! sedimentation flux at surface is added to precip flux at surface @@ -3770,7 +3770,7 @@ subroutine micro_mg_tend ( & prect(i) = prect(i) + faloutg(nlev) * (tx3*0.001_r8) preci(i) = preci(i) + faloutg(nlev) * (tx3*0.001_r8) - end do !! nstep loop + enddo !! nstep loop endif ! if (lprnt) write(0,*)' qgtnds=',qgtend(1,:) !--ag @@ -3813,18 +3813,18 @@ subroutine micro_mg_tend ( & ! switch for specification of droplet and crystal number if (nccons) then dumnc(i,k) = ncnst*rhoinv(i,k)*lcldm(i,k) - end if + endif ! switch for specification of cloud ice number if (nicons) then dumni(i,k) = ninst*rhoinv(i,k)*icldm(i,k) - end if + endif !++ag ! switch for specification of graupel number if (ngcons) then dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) - end if + endif !--ag if (dumc(i,k) < qsmall) dumnc(i,k) = zero @@ -3868,8 +3868,8 @@ subroutine micro_mg_tend ( & dum1 = - xlf * tx2 * dums(i,k) tlat(i,k) = dum1 + tlat(i,k) meltsdttot(i,k) = dum1 + meltsdttot(i,k) - end if - end if + endif + endif enddo enddo @@ -3904,8 +3904,8 @@ subroutine micro_mg_tend ( & dum1 = - xlf*tx2*dumg(i,k) tlat(i,k) = dum1 + tlat(i,k) meltsdttot(i,k) = dum1 + meltsdttot(i,k) - end if - end if + endif + endif enddo enddo @@ -3957,8 +3957,8 @@ subroutine micro_mg_tend ( & frzrdttot(i,k) = dum1 + frzrdttot(i,k) tlat(i,k) = dum1 + tlat(i,k) - end if - end if + endif + endif enddo enddo @@ -3992,8 +3992,8 @@ subroutine micro_mg_tend ( & qitend(i,k) = ((one-dum)*dumi(i,k)-qi(i,k)) * oneodt nitend(i,k) = ((one-dum)*dumni(i,k)-ni(i,k)) * oneodt tlat(i,k) = tlat(i,k) - xlf*tx2*dumi(i,k) - end if - end if + endif + endif enddo enddo @@ -4029,8 +4029,8 @@ subroutine micro_mg_tend ( & qctend(i,k) = ((one-dum)*dumc(i,k)-qc(i,k)) * oneodt nctend(i,k) = ((one-dum)*dumnc(i,k)-nc(i,k)) * oneodt tlat(i,k) = tlat(i,k) + xlf*tx2 - end if - end if + endif + endif enddo enddo ! remove any excess over-saturation, which is possible due to non-linearity when adding @@ -4077,10 +4077,10 @@ subroutine micro_mg_tend ( & ! for output qvres(i,k) = -dum tlat(i,k) = tlat(i,k) + dum*tx1 - end if + endif enddo enddo - end if + endif ! if (lprnt) write(0,*)' tlat7=',tlat(1,:)*deltat @@ -4249,7 +4249,7 @@ subroutine micro_mg_tend ( & lamcrad(i,k) = zero pgamrad(i,k) = zero effc_fn(i,k) = ten - end if + endif enddo enddo ! recalculate 'final' rain size distribution parameters @@ -4266,9 +4266,9 @@ subroutine micro_mg_tend ( & if (dum /= dumnr(i,k)) then ! adjust number conc if needed to keep mean size in reasonable range nrtend(i,k) = (dumnr(i,k)*precip_frac(i,k)-nr(i,k)) *oneodt - end if + endif - end if + endif enddo enddo ! recalculate 'final' snow size distribution parameters @@ -4290,10 +4290,10 @@ subroutine micro_mg_tend ( & tx1 = (two*pi*1.e-2_r8) / (lams(i,k)*lams(i,k)*lams(i,k)) sadsnow(i,k) = tx1*dumns0*rho(i,k) ! m2/m3 -> cm2/cm3 - end if + endif - end do ! vertical k loop + enddo ! vertical k loop enddo do k=1,nlev do i=1,mgncol @@ -4307,9 +4307,9 @@ subroutine micro_mg_tend ( & if (qg(i,k)+qgtend(i,k)*deltat < qsmall) ngtend(i,k) = -ng(i,k) * oneodt !--ag - end do + enddo - end do + enddo ! DO STUFF FOR OUTPUT: !================================================== @@ -4459,10 +4459,10 @@ subroutine micro_mg_tend ( & else acsrfl(i,k) = zero fcsrfl(i,k) = zero - end if + endif - end do - end do + enddo + enddo do k=1,nlev do i = 1,mgncol @@ -4520,7 +4520,7 @@ subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol,n if (Atmp > zero) then rercld(i,k) = rercld(i,k) + three *(qric(i,k) + qcic(i,k)) / (four * rhow * Atmp) - end if + endif enddo enddo end subroutine calc_rercld diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/module_MYJPBL_wrapper.meta index 43e63b4ab..427088b86 100644 --- a/physics/module_MYJPBL_wrapper.meta +++ b/physics/module_MYJPBL_wrapper.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -659,9 +659,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/module_MYJSFC_wrapper.meta b/physics/module_MYJSFC_wrapper.meta index 1201fd56b..65ccc7dd9 100644 --- a/physics/module_MYJSFC_wrapper.meta +++ b/physics/module_MYJSFC_wrapper.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -740,9 +740,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 2327af72a..9d720b9f8 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -159,7 +159,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & icloud_bl, do_mynnsfclay, & & imp_physics, imp_physics_gfdl, & & imp_physics_thompson, imp_physics_wsm6, & - & ltaerosol, lprnt, huge, errmsg, errflg ) + & ltaerosol, spp_wts_pbl, spp_pbl, lprnt, huge, errmsg, errflg ) ! should be moved to inside the mynn: use machine, only: kind_phys @@ -204,7 +204,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & bl_mynn_mixqt, & & bl_mynn_output, & & imp_physics, imp_physics_wsm6, & - & imp_physics_thompson, imp_physics_gfdl + & imp_physics_thompson, imp_physics_gfdl, & + & spp_pbl real, intent(in) :: & & bl_mynn_closure @@ -218,7 +219,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !MISC CONFIGURATION OPTIONS INTEGER, PARAMETER :: & - & spp_pbl=0, & & bl_mynn_mixscalars=1 LOGICAL :: & & FLAG_QI, FLAG_QNI, FLAG_QC, FLAG_QNC, & @@ -227,7 +227,7 @@ SUBROUTINE mynnedmf_wrapper_run( & LOGICAL, PARAMETER :: cycling = .false. INTEGER, PARAMETER :: param_first_scalar = 1 INTEGER :: & - & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni + & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni !MYNN-1D REAL(kind=kind_phys), intent(in) :: delt, dtf @@ -272,14 +272,16 @@ SUBROUTINE mynnedmf_wrapper_run( & & Tsq, Qsq, Cov, exch_h, exch_m real(kind=kind_phys), dimension(:), intent(in) :: xmu real(kind=kind_phys), dimension(:,:), intent(in) :: htrsw, htrlw + ! spp_wts_pbl only allocated if spp_pbl == 1 + real(kind_phys), dimension(:,:), intent(in) :: spp_wts_pbl + !LOCAL real(kind=kind_phys), dimension(im,levs) :: & & sqv,sqc,sqi,qnc,qni,ozone,qnwfa,qnifa, & & dz, w, p, rho, th, qv, delp, & & RUBLTEN, RVBLTEN, RTHBLTEN, RQVBLTEN, & & RQCBLTEN, RQNCBLTEN, RQIBLTEN, RQNIBLTEN, & - & RQNWFABLTEN, RQNIFABLTEN, & - & pattern_spp_pbl + & RQNWFABLTEN, RQNIFABLTEN real(kind=kind_phys), allocatable :: old_ozone(:,:) !smoke/chem arrays @@ -556,9 +558,9 @@ SUBROUTINE mynnedmf_wrapper_run( & ! qi(i,k)=qi(i,k)/(1.0 - qvsh(i,k)) rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)) w(i,k) = -omega(i,k)/(rho(i,k)*grav) - pattern_spp_pbl(i,k)=0.0 enddo enddo + do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn @@ -732,7 +734,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & ,det_thl3D=det_thl,det_sqv3D=det_sqv & & ,nupdraft=nupdraft,maxMF=maxMF & !output & ,ktop_plume=ktop_plume & !output - & ,spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl & !input + & ,spp_pbl=spp_pbl,pattern_spp_pbl=spp_wts_pbl & !input & ,RTHRATEN=htrlw & !input & ,FLAG_QI=flag_qi,FLAG_QNI=flag_qni & !input & ,FLAG_QC=flag_qc,FLAG_QNC=flag_qnc & !input diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index b413e81de..60668ba88 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -141,9 +141,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1312,6 +1312,21 @@ dimensions = () type = logical intent = in +[spp_wts_pbl] + standard_name = spp_weights_for_pbl_scheme + long_name = spp weights for pbl scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_pbl] + standard_name = control_for_pbl_spp_perturbations + long_name = control for pbl spp perturbations + units = count + dimensions = () + type = integer + intent = in [lprnt] standard_name = flag_print long_name = control flag for diagnostic print out @@ -1336,9 +1351,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index c8c5c1db4..150a66472 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -88,6 +88,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & FLHC, FLQC, & & U10, V10, TH2, T2, Q2, & & wstar, CHS2, CQS2, & + & spp_wts_sfc, spp_sfc, & ! & CP, G, ROVCP, R, XLV, & ! & SVP1, SVP2, SVP3, SVPT0, & ! & EP1,EP2,KARMAN, & @@ -143,7 +144,6 @@ SUBROUTINE mynnsfc_wrapper_run( & !MISC CONFIGURATION OPTIONS INTEGER, PARAMETER :: & - & spp_pbl = 0, & & isftcflx = 0, & !control: 0 & iz0tlnd = 0, & !control: 0 & isfflx = 1 @@ -155,12 +155,15 @@ SUBROUTINE mynnsfc_wrapper_run( & integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) + integer, intent(in) :: spp_sfc ! flag for using SPP perturbations + real(kind=kind_phys), intent(in) :: delt !Input data integer, dimension(:), intent(in) :: vegtype real(kind=kind_phys), dimension(:), intent(in) :: & & sigmaf,shdmax,z0pert,ztpert + real(kind_phys), dimension(:,:), intent(in) :: spp_wts_sfc real(kind=kind_phys), dimension(:,:), & & intent(in) :: phii @@ -201,13 +204,13 @@ SUBROUTINE mynnsfc_wrapper_run( & & CHS2, CQS2, rmol, zol, mol, ch, & & lh, wstar !LOCAL - real, dimension(im) :: & + real(kind=kind_phys), dimension(im) :: & & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & & cpm, qgh, qfx, snowh_wat real(kind=kind_phys), dimension(im,levs) :: & - & pattern_spp_pbl, dz, th, qv + & dz, th, qv !MYNN-1D INTEGER :: k, i @@ -228,15 +231,21 @@ SUBROUTINE mynnsfc_wrapper_run( & ! endif ! prep MYNN-only variables + dz(:,:) = 0 + th(:,:) = 0 + qv(:,:) = 0 + hfx(:) = 0 + qfx(:) = 0 + rmol(:) = 0 do k=1,2 !levs do i=1,im dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv th(i,k)=t3d(i,k)/exner(i,k) !qc(i,k)=MAX(qgrs(i,k,ntcw),0.0) qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) - pattern_spp_pbl(i,k)=0.0 enddo enddo + do i=1,im if (slmsk(i)==1. .or. slmsk(i)==2.)then !sea/land/ice mask (=0/1/2) in FV3 xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn @@ -330,11 +339,12 @@ SUBROUTINE mynnsfc_wrapper_run( & QGH=qgh,QSFC=qsfc, & U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2, & GZ1OZ0=GZ1OZ0,WSPD=wspd,wstar=wstar, & - spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl, & + spp_sfc=spp_sfc,pattern_spp_sfc=spp_wts_sfc, & ids=1,ide=im, jds=1,jde=1, kds=1,kde=levs, & ims=1,ime=im, jms=1,jme=1, kms=1,kme=levs, & - its=1,ite=im, jts=1,jte=1, kts=1,kte=levs ) - + its=1,ite=im, jts=1,jte=1, kts=1,kte=levs, & + errmsg=errmsg, errflg=errflg ) + if (errflg/=0) return !! POST MYNN SURFACE LAYER (INTERSTITIAL) WORK: !do i = 1, im diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index 39a05f858..4e73504d7 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -834,6 +834,21 @@ type = real kind = kind_phys intent = inout +[spp_wts_sfc] + standard_name = spp_weights_for_surface_layer_scheme + long_name = spp weights for surface layer scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_sfc] + standard_name = control_for_surface_layer_spp_perturbations + long_name = control for surface layer spp perturbations + units = count + dimensions = () + type = integer + intent = in [lprnt] standard_name = flag_print long_name = control flag for diagnostic print out @@ -850,9 +865,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/module_SGSCloud_RadPost.meta b/physics/module_SGSCloud_RadPost.meta index ed316433b..6ad91d496 100644 --- a/physics/module_SGSCloud_RadPost.meta +++ b/physics/module_SGSCloud_RadPost.meta @@ -92,9 +92,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/module_SGSCloud_RadPre.meta b/physics/module_SGSCloud_RadPre.meta index 95d73432d..28c1b7da6 100644 --- a/physics/module_SGSCloud_RadPre.meta +++ b/physics/module_SGSCloud_RadPre.meta @@ -443,9 +443,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 3ab549e98..36ff3ebf7 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -670,9 +670,10 @@ SUBROUTINE mynn_bl_driver( & LOGICAL :: INITIALIZE_QKE ! Stochastic fields - INTEGER, INTENT(IN) ::spp_pbl - REAL, DIMENSION( ims:ime, kms:kme), INTENT(IN),OPTIONAL ::pattern_spp_pbl - REAL, DIMENSION(KTS:KTE) ::rstoch_col + INTEGER, INTENT(IN) :: spp_pbl + !GJF: this array must be assumed-shape since it's conditionally-allocated + REAL, DIMENSION(:,:), INTENT(IN) :: pattern_spp_pbl + REAL, DIMENSION(KTS:KTE) :: rstoch_col ! Substepping TKE INTEGER :: nsub diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 3183ca4bf..c23b6d1d8 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1026,7 +1026,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & re_cloud, re_ice, re_snow INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch - REAL, DIMENSION(ims:ime,kms:kme_stoch,jms:jme), INTENT(IN), OPTIONAL:: & + REAL, DIMENSION(:,:), INTENT(IN) :: & rand_pert INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs @@ -1122,23 +1122,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! No need to test for every subcycling step test_only_once: if (first_time_step .and. istep==1) then - ! DH* 2020-06-05: The stochastic perturbations code was retrofitted - ! from a newer version of the Thompson MP scheme, but it has not been - ! tested yet. - if (rand_perturb_on .ne. 0) then - errmsg = 'Logic error in mp_gt_driver: the stochastic perturbations code ' // & - 'has not been tested yet with this version of the Thompson scheme' - errflg = 1 - return - end if ! Activate this code when removing the guard above - !if (rand_perturb_on .ne. 0 .and. .not. present(rand_pert)) then - ! errmsg = 'Logic error in mp_gt_driver: random perturbations are on, ' // & - ! 'but optional argument rand_pert is not present' - ! errflg = 1 - ! return - !end if - ! *DH 2020-06-05 if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then @@ -1252,16 +1236,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ndt = max(nint(dt_in/dt_inner),1) dt = dt_in/ndt if(dt_in .le. dt_inner) dt= dt_in - if(nsteps>1 .and. ndt>1) then - if (present(errmsg) .and. present(errflg)) then - write(errmsg, '(a)') 'Logic error in mp_gt_driver: inner loop cannot be used with subcycling' - errflg = 1 - return - else - write(*,'(a)') 'Warning: inner loop cannot be used with subcycling, resetting ndt=1' - ndt = 1 - endif - endif do it = 1, ndt @@ -1300,7 +1274,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & !+---+-----------------------------------------------------------------+ !..Introduce stochastic parameter perturbations by creating as many scalar rand1, rand2, ... !.. variables as needed to perturb different pieces of microphysics. gthompsn 21Mar2018 -! Setting spp_mp to 1 gives graupel Y-intercept pertubations (2^0) +! Setting spp_mp_opt to 1 gives graupel Y-intercept pertubations (2^0) ! 2 gives cloud water distribution gamma shape parameter perturbations (2^1) ! 4 gives CCN & IN activation perturbations (2^2) ! 3 gives both 1+2 @@ -1314,11 +1288,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rand2 = 0.0 rand3 = 0.0 if (rand_perturb_on .ne. 0) then - if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1,j) + if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1) m = RSHIFT(ABS(rand_perturb_on),1) - if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1,j)*2. + if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. m = RSHIFT(ABS(rand_perturb_on),2) - if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1,j)+ABS(min_rand)) + if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+ABS(min_rand)) m = RSHIFT(ABS(rand_perturb_on),3) endif !+---+-----------------------------------------------------------------+ @@ -2188,7 +2162,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ni(k) = MAX(R2, ni1d(k)*rho(k)) if (ni(k).le. R2) then lami = cie(2)/5.E-6 - ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) endif L_qi(k) = .true. lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi @@ -2196,7 +2170,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - ni(k) = MIN(999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i @@ -2901,7 +2875,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !> - Freezing of aqueous aerosols based on Koop et al (2001, Nature) xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave - if (is_aerosol_aware .AND. homogIce .AND. (xni.le.999.E3) & + if (is_aerosol_aware .AND. homogIce .AND. (xni.le.499.E3) & & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) pni_iha(k) = xnc*odts @@ -3237,7 +3211,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - xni = MIN(999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + xni = MIN(499.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -3248,8 +3222,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) - if (xni.gt.999.E3) & - niten(k) = (999.E3-ni1d(k)*rho(k))*odts*orho + if (xni.gt.499.E3) & + niten(k) = (499.E3-ni1d(k)*rho(k))*odts*orho !> - Rain tendency qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) & @@ -4187,7 +4161,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = cie(2)/300.E-6 endif ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 999.D3/rho(k)) + 499.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index c98dc2169..5f227750a 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -161,10 +161,11 @@ SUBROUTINE SFCLAY_mynn( & QGH,QSFC, & U10,V10,TH2,T2,Q2, & GZ1OZ0,WSPD,WSTAR, & - spp_pbl,pattern_spp_pbl, & + spp_sfc,pattern_spp_sfc, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, & + errmsg, errflg ) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -258,6 +259,8 @@ SUBROUTINE SFCLAY_mynn( & !-- jte end index for j in tile !-- kts start index for k in tile !-- kte end index for k in tile +!-- errmsg CCPP error message +!-- errflg CCPP error code !================================================================= ! SCALARS !=================================== @@ -271,7 +274,7 @@ SUBROUTINE SFCLAY_mynn( & !NAMELIST/CONFIGURATION OPTIONS: INTEGER, INTENT(IN) :: ISFFLX, LSM, LSM_RUC INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND - INTEGER, OPTIONAL, INTENT(IN) :: spp_pbl, psi_opt + INTEGER, OPTIONAL, INTENT(IN) :: spp_sfc, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -292,8 +295,9 @@ SUBROUTINE SFCLAY_mynn( & U3D,V3D, & th3d,pi3d - REAL, DIMENSION( ims:ime, kms:kme), OPTIONAL, & - INTENT(IN) :: pattern_spp_pbl + !GJF: This array must be assumed-shape since it is conditionally-allocated + REAL, DIMENSION( :,: ), & + INTENT(IN) :: pattern_spp_sfc !=================================== ! 2D VARIABLES !=================================== @@ -352,9 +356,13 @@ SUBROUTINE SFCLAY_mynn( & & QFLX_wat, QFLX_lnd, QFLX_ice, & & qsfc_wat, qsfc_lnd, qsfc_ice +! CCPP error handling + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + !ADDITIONAL OUTPUT !JOE-begin - REAL, DIMENSION( ims:ime ) :: qstar + REAL, DIMENSION( ims:ime ) :: qstar !JOE-end !=================================== ! 1D LOCAL ARRAYS @@ -396,11 +404,12 @@ SUBROUTINE SFCLAY_mynn( & QC1D(i)=QC3D(i,kts) P1D(i) =P3D(i,kts) T1D(i) =T3D(i,kts) - if (spp_pbl==1) then - rstoch1D(i)=pattern_spp_pbl(i,kts) + if (spp_sfc==1) then + rstoch1D(i)=pattern_spp_sfc(i,kts) else rstoch1D(i)=0.0 endif + qstar(i)=0.0 ENDDO IF (itimestep==1 .AND. iter==1) THEN @@ -410,9 +419,6 @@ SUBROUTINE SFCLAY_mynn( & UST_LND(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) UST_ICE(i)=MAX(0.04*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) MOL(i)=0.0 - qstar(i)=0.0 - QFX(i)=0. - HFX(i)=0. QFLX(i)=0. HFLX(i)=0. if ( LSM == LSM_RUC ) then @@ -461,12 +467,12 @@ SUBROUTINE SFCLAY_mynn( & PSIM,PSIH, & HFLX,HFX,QFLX,QFX,LH,FLHC,FLQC, & QGH,QSFC,U10,V10,TH2,T2,Q2, & - GZ1OZ0,WSPD,wstar, & - spp_pbl,rstoch1D, & + GZ1OZ0,WSPD,wstar,qstar, & + spp_sfc,rstoch1D, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ) + its,ite, jts,jte, kts,kte, & + errmsg, errflg ) END SUBROUTINE SFCLAY_MYNN @@ -509,12 +515,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & HFLX,HFX,QFLX,QFX,LH,FLHC,FLQC, & QGH,QSFC, & U10,V10,TH2,T2,Q2, & - GZ1OZ0,WSPD,wstar, & - spp_pbl,rstoch1D, & + GZ1OZ0,WSPD,wstar,qstar, & + spp_sfc,rstoch1D, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ) + its,ite, jts,jte, kts,kte, & + errmsg, errflg ) !------------------------------------------------------------------- IMPLICIT NONE @@ -537,7 +543,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !----------------------------- INTEGER, INTENT(IN) :: ISFFLX INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, INTENT(IN) :: spp_pbl, psi_opt + INTEGER, INTENT(IN) :: spp_sfc, psi_opt integer, intent(in) :: ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -563,9 +569,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & dz8w1d, & dz2w1d - REAL, DIMENSION( ims:ime ), INTENT(INOUT) :: HFLX,HFX, & - QFLX,QFX,LH, & - MOL,RMOL, & + REAL, DIMENSION( ims:ime ), INTENT(OUT) :: QFX,HFX, & + RMOL + REAL, DIMENSION( ims:ime ), INTENT(INOUT) :: HFLX,QFLX, & + LH,MOL, & QGH,QSFC, & ZNT, & ZOL, & @@ -610,8 +617,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !-------------------------------------------- !JOE-additinal output - REAL, DIMENSION( ims:ime ) :: wstar,qstar + REAL, DIMENSION( ims:ime ), INTENT(OUT) :: wstar,qstar !JOE-end + +! CCPP error handling + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + !---------------------------------------------------------------- ! LOCAL VARS !---------------------------------------------------------------- @@ -661,8 +673,8 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !------------------------------------------------------------------- DO I=its,ite - ! PSFC ( in cmb) is used later in saturation checks - PSFC(I)=PSFCPA(I)/1000. + ! PSFC ( in cmb) is used later in saturation checks + PSFC(I)=PSFCPA(I)/1000. !tgs - do computations if flag_iter(i) = .true. if ( flag_iter(i) ) then @@ -1111,7 +1123,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif !-end wave model check ! add stochastic perturbation of ZNT - if (spp_pbl==1) then + if (spp_sfc==1) then ZNTstoch_wat(I) = MAX(ZNT_wat(I) + ZNT_wat(I)*1.0*rstoch1D(i), 1e-6) else ZNTstoch_wat(I) = ZNT_wat(I) @@ -1140,29 +1152,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF ( ISFTCFLX .EQ. 0 ) THEN IF (COARE_OPT .EQ. 3.0) THEN CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ELSE !presumably, this will be published soon, but hasn't yet CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ENDIF ELSEIF ( ISFTCFLX .EQ. 1 ) THEN IF (COARE_OPT .EQ. 3.0) THEN CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ELSE CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ENDIF ELSEIF ( ISFTCFLX .EQ. 2 ) THEN CALL garratt_1992(ZT_wat(i),ZQ_wat(i),ZNTstoch_wat(i),restar,2.0) ELSEIF ( ISFTCFLX .EQ. 3 ) THEN IF (COARE_OPT .EQ. 3.0) THEN CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ELSE CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ENDIF ELSEIF ( ISFTCFLX .EQ. 4 ) THEN !GFS zt formulation @@ -1173,10 +1185,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & !DEFAULT TO COARE 3.0/3.5 IF (COARE_OPT .EQ. 3.0) THEN CALL fairall_etal_2003(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ELSE CALL fairall_etal_2014(ZT_wat(i),ZQ_wat(i),restar,UST_wat(i),visc,& - rstoch1D(i),spp_pbl) + rstoch1D(i),spp_sfc) ENDIF ENDIF IF (debug_code > 1) THEN @@ -1201,7 +1213,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & endif ! add stochastic perturbaction of ZNT - if (spp_pbl==1) then + if (spp_sfc==1) then ZNTstoch_lnd(I) = MAX(ZNT_lnd(I) + ZNT_lnd(I)*1.0*rstoch1D(i), 1e-6) else ZNTstoch_lnd(I) = ZNT_lnd(I) @@ -1222,8 +1234,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF ( PRESENT(IZ0TLND) ) THEN IF ( IZ0TLND .LE. 1 ) THEN CALL zilitinkevich_1995(ZNTstoch_lnd(i),ZT_lnd(i),ZQ_lnd(i),restar,& - UST_lnd(I),KARMAN,1.0,IZ0TLND,spp_pbl,rstoch1D(i)) + UST_lnd(I),KARMAN,1.0,IZ0TLND,spp_sfc,rstoch1D(i)) ELSEIF ( IZ0TLND .EQ. 2 ) THEN + ! DH note - at this point, qstar is either not initialized + ! or initialized to zero, but certainly not set correctly + errmsg = 'Logic error: qstar is not set correctly when calling Yang_2008' + errflg = 1 + return CALL Yang_2008(ZNTSTOCH_lnd(i),ZT_lnd(i),ZQ_lnd(i),UST_lnd(i),MOL(I),& qstar(I),restar,visc) ELSEIF ( IZ0TLND .EQ. 3 ) THEN @@ -1237,7 +1254,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & ELSE !DEFAULT TO ZILITINKEVICH CALL zilitinkevich_1995(ZNTSTOCH_lnd(i),ZT_lnd(i),ZQ_lnd(i),restar,& - UST_lnd(I),KARMAN,1.0,0,spp_pbl,rstoch1D(i)) + UST_lnd(I),KARMAN,1.0,0,spp_sfc,rstoch1D(i)) ENDIF ENDIF IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN @@ -1263,7 +1280,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, & IF (icy(I)) THEN ! add stochastic perturbaction of ZNT - if (spp_pbl==1) then + if (spp_sfc==1) then ZNTstoch_ice(I) = MAX(ZNT_ice(I) + ZNT_ice(I)*1.0*rstoch1D(i), 1e-6) else ZNTstoch_ice(I) = ZNT_ice(I) @@ -2246,7 +2263,7 @@ END SUBROUTINE SFCLAY1D_mynn !! to work with the Noah LSM and may be specific for that !! LSM only. Tests with RUC LSM showed no improvements. SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& - & landsea,IZ0TLND2,spp_pbl,rstoch) + & landsea,IZ0TLND2,spp_sfc,rstoch) IMPLICIT NONE REAL, INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea @@ -2255,7 +2272,7 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& REAL :: CZIL !=0.100 in Chen et al. (1997) !=0.075 in Zilitinkevich (1995) !=0.500 in Lemone et al. (2008) - INTEGER, INTENT(IN) :: spp_pbl + INTEGER, INTENT(IN) :: spp_sfc REAL, INTENT(IN) :: rstoch @@ -2296,7 +2313,7 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& ! stochastically perturb thermal and moisture roughness length. ! currently set to half the amplitude: - if (spp_pbl==1) then + if (spp_sfc==1) then Zt = Zt + Zt * 0.5 * rstoch Zt = MAX(Zt, 0.0001) Zq = Zt @@ -2461,11 +2478,11 @@ END SUBROUTINE garratt_1992 !!(1992, p. 102), is available for flows with Ren < 2. !! !!This is for use over water only. - SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl) + SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE REAL, INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_pbl + INTEGER, INTENT(IN):: spp_sfc REAL, INTENT(OUT) :: Zt,Zq IF (Ren .le. 2.) then @@ -2484,7 +2501,7 @@ SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl) ENDIF - if (spp_pbl==1) then + if (spp_sfc==1) then Zt = Zt + Zt * 0.5 * rstoch Zq = Zt endif @@ -2505,18 +2522,18 @@ END SUBROUTINE fairall_etal_2003 !! COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data !! [Fairall et al. (2014? coming soon, not yet published as of July 2014)]. !! This is for use over water only. - SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl) + SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc) IMPLICIT NONE REAL, INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_pbl + INTEGER, INTENT(IN):: spp_sfc REAL, INTENT(OUT) :: Zt,Zq !Zt = (5.5e-5)*(Ren**(-0.60)) Zt = MIN(1.6E-4, 5.8E-5/(Ren**0.72)) Zq = Zt - IF (spp_pbl ==1) THEN + IF (spp_sfc ==1) THEN Zt = MAX(Zt + Zt*0.5*rstoch,2.0e-9) Zq = MAX(Zt + Zt*0.5*rstoch,2.0e-9) ELSE @@ -3749,4 +3766,3 @@ REAL function psih_unstable(zolf,psi_opt) !======================================================================== END MODULE module_sf_mynn - diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index b5abd871b..4c3a53c88 100644 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -738,10 +738,10 @@ subroutine csnow_glacier (isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , ! thermal conductivity of snow do iz = isnow+1, 0 - tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) +! tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) ! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976 ! tksno(iz) = 0.35 ! constant -! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) + tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) ! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981) enddo @@ -2657,7 +2657,7 @@ subroutine compact_glacier (nsnow ,nsoil ,dt ,stc ,snice , & !in real (kind=kind_phys), parameter :: c4 = 0.04 !< [1/k] real (kind=kind_phys), parameter :: c5 = 2.0 !< real (kind=kind_phys), parameter :: dm = 100.0 !< upper limit on destructive metamorphism compaction [kg/m3] - real (kind=kind_phys), parameter :: eta0 = 0.8e+6 !< viscosity coefficient [kg-s/m2] + real (kind=kind_phys), parameter :: eta0 = 1.8e+6 !< viscosity coefficient [kg-s/m2] !according to anderson, it is between 0.52e6~1.38e6 real (kind=kind_phys) :: burden !< pressure of overlying snow [kg/m2] real (kind=kind_phys) :: ddz1 !< rate of settling of snow pack due to destructive metamorphism. diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 81dd1dceb..944446085 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -2532,10 +2532,10 @@ subroutine csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso ! thermal conductivity of snow do iz = isnow+1, 0 - tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) +! tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) ! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976 ! tksno(iz) = 0.35 ! constant -! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) + tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) ! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981) enddo @@ -7365,7 +7365,7 @@ subroutine compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in real (kind=kind_phys), parameter :: c4 = 0.04 ![1/k] real (kind=kind_phys), parameter :: c5 = 2.0 ! real (kind=kind_phys), parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3] - real (kind=kind_phys), parameter :: eta0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + real (kind=kind_phys), parameter :: eta0 = 1.8e+6 !viscosity coefficient [kg-s/m2] !according to anderson, it is between 0.52e6~1.38e6 real (kind=kind_phys) :: burden !pressure of overlying snow [kg/m2] real (kind=kind_phys) :: ddz1 !rate of settling of snow pack due to destructive metamorphism. diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index a2b0f398a..b39610bc8 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -60,7 +60,7 @@ MODULE module_sf_ruclsm !>\section gen_lsmruc GSD RUC LSM General Algorithm !! @{ SUBROUTINE LSMRUC( & - DT,init,restart,KTAU,iter,NSL, & + DT,init,lsm_cold_start,KTAU,iter,NSL, & graupelncv,snowncv,rainncv,raincv, & ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & rhosnf,precipfr, & @@ -97,7 +97,7 @@ SUBROUTINE LSMRUC( & !----------------------------------------------------------------- !-- DT time step (second) ! init - flag for initialization -! restart - flag for restart run +!lsm_cold_start - flag for cold start run ! ktau - number of time step ! NSL - number of soil layers ! NZS - number of levels in soil @@ -166,7 +166,7 @@ SUBROUTINE LSMRUC( & ! INTEGER, PARAMETER :: nddzs=2*(nzss-2) REAL, INTENT(IN ) :: DT - LOGICAL, INTENT(IN ) :: myj,frpcpn,init,restart + LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start INTEGER, INTENT(IN ) :: NLCAT, NSCAT ! , mosaic_lu, mosaic_soil INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, & ims,ime, jms,jme, kms,kme, & @@ -423,7 +423,7 @@ SUBROUTINE LSMRUC( & !> - Initialize soil/vegetation parameters !--- This is temporary until SI is added to mass coordinate ---!!!!! - if(init .and. (.not. restart) .and. iter == 1) then + if(init .and. (lsm_cold_start) .and. iter == 1) then DO J=jts,jte DO i=its,ite ! do k=1,nsl diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 1bb6847eb..c2d873065 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -31,9 +31,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -583,9 +583,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/moninshoc.meta b/physics/moninshoc.meta index ab4103891..f01b2c58d 100644 --- a/physics/moninshoc.meta +++ b/physics/moninshoc.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -522,9 +522,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/mp_fer_hires.meta b/physics/mp_fer_hires.meta index 08c6d939a..9f7c63d4d 100644 --- a/physics/mp_fer_hires.meta +++ b/physics/mp_fer_hires.meta @@ -87,9 +87,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -106,9 +106,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -336,9 +336,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index e96f0e112..7c76ea933 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -91,7 +91,7 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & real(kind_phys) :: orho(1:ncol,1:nlev) ! m3 kg-1 real(kind_phys) :: nc_local(1:ncol,1:nlev) ! needed because nc is only allocated if is_aerosol_aware is true ! - real (kind=kind_phys) :: h_01, airmass, niIN3, niCCN3 + real (kind=kind_phys) :: h_01, z1, niIN3, niCCN3 integer :: i, k ! Initialize the CCPP error handling variables @@ -192,8 +192,8 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & endif niCCN3 = -1.0*ALOG(naCCN1/naCCN0)/h_01 nwfa(i,1) = naCCN1+naCCN0*exp(-((hgt(i,2)-hgt(i,1))/1000.)*niCCN3) - airmass = 1./orho(i,1) * (hgt(i,2)-hgt(i,1))*area(i) ! kg - nwfa2d(i) = nwfa(i,1) * 0.000196 * (airmass*5.E-11) + z1 = hgt(i,2)-hgt(i,1) + nwfa2d(i) = nwfa(i,1) * 0.000196 * (50./z1) do k = 2, nlev nwfa(i,k) = naCCN1+naCCN0*exp(-((hgt(i,k)-hgt(i,1))/1000.)*niCCN3) enddo @@ -212,8 +212,8 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & !+---+-----------------------------------------------------------------+ if (mpirank==mpiroot) write(*,*) ' Apparently there are no initial CCN aerosol surface emission rates.' do i = 1, ncol - airmass = 1./orho(i,1) * (hgt(i,2)-hgt(i,1))*area(i) ! kg - nwfa2d(i) = nwfa(i,1) * 0.000196 * (airmass*5.E-11) + z1 = hgt(i,2)-hgt(i,1) + nwfa2d(i) = nwfa(i,1) * 0.000196 * (50./z1) enddo else if (mpirank==mpiroot) write(*,*) ' Apparently initial CCN aerosol surface emission rates are present.' @@ -308,6 +308,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm, reset_dBZ, do_radar_ref, & mpicomm, mpirank, mpiroot, blkno, & ext_diag, diag3d, reset_diag3d, & + spp_wts_mp, spp_mp, & errmsg, errflg) implicit none @@ -372,11 +373,16 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg + + ! SPP + integer, intent(in) :: spp_mp + real(kind_phys), intent(in) :: spp_wts_mp(:,:) ! Local variables ! Reduced time step if subcycling is used real(kind_phys) :: dtstep + integer :: ndt ! Air density real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 ! Water vapor mixing ratio (instead of specific humidity) @@ -401,11 +407,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, parameter :: has_reqc = 0 integer, parameter :: has_reqi = 0 integer, parameter :: has_reqs = 0 - ! Random perturbations are turned off in CCPP for now, - ! hasn't been tested yet with this version of module_mp_thompson.F90 - integer, parameter :: rand_perturb_on = 0 integer, parameter :: kme_stoch = 1 - !real(kind_phys) :: rand_pert(1:ncol,1:kme_stoch) + integer :: spp_mp_opt ! Dimensions used in mp_gt_driver integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -456,38 +459,54 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & errmsg = '' errflg = 0 - ! Check initialization state - if (.not.is_initialized) then - write(errmsg, fmt='((a))') 'mp_thompson_run called before mp_thompson_init' - errflg = 1 - return + if (first_time_step .and. istep==1 .and. blkno==1) then + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_thompson_run called before mp_thompson_init' + errflg = 1 + return + end if + ! Check forr optional arguments of aerosol-aware microphysics + if (is_aerosol_aware .and. .not. (present(nc) .and. & + present(nwfa) .and. & + present(nifa) .and. & + present(nwfa2d) .and. & + present(nifa2d) )) then + write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_run:', & + ' aerosol-aware microphysics require all of the', & + ' following optional arguments:', & + ' nc, nwfa, nifa, nwfa2d, nifa2d' + errflg = 1 + return + end if + ! Consistency cheecks - subcycling and inner loop at the same time are not supported + if (nsteps>1 .and. dt_inner < dtp) then + write(errmsg,'(*(a))') "Logic error: Subcycling and inner loop cannot be used at the same time" + errflg = 1 + return + else if (mpirank==mpiroot .and. nsteps>1) then + write(*,'(a,i0,a,a,f6.2,a)') 'Thompson MP is using ', nsteps, ' substep(s) per time step with an ', & + 'effective time step of ', dtp/real(nsteps, kind=kind_phys), ' seconds' + else if (mpirank==mpiroot .and. dt_inner < dtp) then + ndt = max(nint(dtp/dt_inner),1) + write(*,'(a,i0,a,a,f6.2,a)') 'Thompson MP is using ', ndt, ' inner loops per time step with an ', & + 'effective time step of ', dtp/real(ndt, kind=kind_phys), ' seconds' + end if end if + ! Set stochastic physics selection to apply all perturbations + if ( spp_mp==7 ) then + spp_mp_opt=7 + else + spp_mp_opt=0 + endif + ! Set reduced time step if subcycling is used if (nsteps>1) then dtstep = dtp/real(nsteps, kind=kind_phys) else dtstep = dtp end if - if (first_time_step .and. istep==1 .and. mpirank==mpiroot .and. blkno==1) then - write(*,'(a,i0,a,a,f8.2,a)') 'Thompson MP is using ', nsteps, ' substep(s) per time step', & - ' with an effective time step of ', dtstep, ' seconds' - end if - - if (first_time_step .and. istep==1) then - if (is_aerosol_aware .and. .not. (present(nc) .and. & - present(nwfa) .and. & - present(nifa) .and. & - present(nwfa2d) .and. & - present(nifa2d) )) then - write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_run:', & - ' aerosol-aware microphysics require all of the', & - ' following optional arguments:', & - ' nc, nwfa, nifa, nwfa2d, nifa2d' - errflg = 1 - return - end if - end if !> - Convert specific humidity to water vapor mixing ratio. !> - Also, hydrometeor variables are mass or number mixing ratio @@ -624,10 +643,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm=refl_10cm, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & - ! DH* 2020-06-05 not passing this optional argument, see - ! comment in module_mp_thompson.F90 / mp_gt_driver - !rand_pert=rand_pert, & + rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & + rand_pert=spp_wts_mp, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & @@ -663,10 +680,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm=refl_10cm, & diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & - ! DH* 2020-06-05 not passing this optional argument, see - ! comment in module_mp_thompson.F90 / mp_gt_driver - !rand_pert=rand_pert, & + rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & + rand_pert=spp_wts_mp, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 248b76cc9..a3bc20615 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -268,9 +268,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -638,6 +638,21 @@ dimensions = () type = logical intent = in +[spp_wts_mp] + standard_name = spp_weights_for_microphysics_scheme + long_name = spp weights for microphysics scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_mp] + standard_name = control_for_microphysics_spp_perturbations + long_name = control for microphysics spp perturbations + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -647,9 +662,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -667,9 +682,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/mp_thompson_post.meta b/physics/mp_thompson_post.meta index 5107bf642..82b035e99 100644 --- a/physics/mp_thompson_post.meta +++ b/physics/mp_thompson_post.meta @@ -24,9 +24,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -126,9 +126,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -146,9 +146,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/mp_thompson_pre.meta b/physics/mp_thompson_pre.meta index c21dd6001..12e812bb3 100644 --- a/physics/mp_thompson_pre.meta +++ b/physics/mp_thompson_pre.meta @@ -46,9 +46,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/ozphys.meta b/physics/ozphys.meta index 5d6a9fff7..485e2a491 100644 --- a/physics/ozphys.meta +++ b/physics/ozphys.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -200,9 +200,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index 070e57e54..8bce7defe 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -199,9 +199,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/phys_tend.meta b/physics/phys_tend.meta index ffb9c0b12..0f78af20b 100644 --- a/physics/phys_tend.meta +++ b/physics/phys_tend.meta @@ -87,9 +87,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/precpd.meta b/physics/precpd.meta index 1b9cb30b6..67f1a530b 100644 --- a/physics/precpd.meta +++ b/physics/precpd.meta @@ -37,9 +37,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -261,9 +261,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index f58ec8d11..c3e0b1293 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -40,7 +40,7 @@ ! ! ! 'progcld3' --- zhao/moorthi prognostic cloud + pdfcld! ! inputs: ! -! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, cnvw,cnvc, ! +! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, ! ! xlat,xlon,slmsk, dz, delp, ! ! ix, nlay, nlp1, ! ! deltaq,sup,kdt,me, ! @@ -876,6 +876,19 @@ subroutine progcld1 & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. The three cloud domain boundaries are defined by @@ -1272,6 +1285,19 @@ subroutine progcld2 & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -1699,6 +1725,19 @@ subroutine progcld3 & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + !> -# Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -2062,6 +2101,19 @@ subroutine progcld4 & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + ! --- compute low, mid, high, total, and boundary layer cloud fractions ! and clouds top/bottom layer indices for low, mid, and high clouds. ! The three cloud domain boundaries are defined by ptopc. The cloud @@ -2416,6 +2468,19 @@ subroutine progcld4o & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + !> - Call gethml() to compute low, mid, high, total, and boundary layer cloud fractions !! and clouds top/bottom layer indices for low, mid, and high clouds. !! The three cloud domain boundaries are defined by ptopc. The cloud @@ -2753,63 +2818,6 @@ subroutine progcld5 & enddo enddo endif -!mz - if (icloud .ne. 0) then -! assign/calculate efective radii for cloud water, ice, rain, snow - - do k = 1, NLAY - do i = 1, IX - rew(i,k) = reliq_def ! default liq radius to 10 micron - rei(i,k) = reice_def ! default ice radius to 50 micron - rer(i,k) = rrain_def ! default rain radius to 1000 micron - res(i,k) = rsnow_def ! default snow radius to 250 micron - enddo - enddo -!> -# Compute effective liquid cloud droplet radius over land. - do i = 1, IX - if (nint(slmsk(i)) == 1) then - do k = 1, NLAY - tem1 = min(1.0, max(0.0, (con_ttp-tlyr(i,k))*0.05)) - rew(i,k) = 5.0 + 5.0 * tem1 - enddo - endif - enddo - -!> -# Compute effective ice cloud droplet radius following Heymsfield -!! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. - - do k = 1, NLAY - do i = 1, IX - tem2 = tlyr(i,k) - con_ttp - - if (cip(i,k) > 0.0) then - tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) - - if (tem2 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 - endif - rei(i,k) = max(25.,rei(i,k)) !mz* HWRF - endif - rei(i,k) = min(rei(i,k), 135.72) !- 1.0315*rei<= 140 microns - enddo - enddo - -!mz -!> -# Compute effective snow cloud droplet radius - do k = 1, NLAY - do i = 1, IX - res(i,k) = 10.0 - enddo - enddo - - endif ! end icloud -!mz end do k = 1, NLAY do i = 1, IX clouds(i,k,1) = cldtot(i,k) @@ -2849,6 +2857,19 @@ subroutine progcld5 & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -2881,7 +2902,7 @@ subroutine progcld6 & & xlat,xlon,slmsk,dz,delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl, & & IX, NLAY, NLP1, & - & uni_cld, lmfshal, lmfdeep2, cldcov, & + & uni_cld, lmfshal, lmfdeep2, cldcov, cnvw, & & re_cloud,re_ice,re_snow, & & lwp_ex, iwp_ex, lwp_fc, iwp_fc, & & dzlay, latdeg, julian, yearlen, & @@ -2976,7 +2997,7 @@ subroutine progcld6 & real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, dzlay, & - & re_cloud, re_ice, re_snow + & re_cloud, re_ice, re_snow, cnvw real (kind=kind_phys), dimension(:), intent(inout) :: & & lwp_ex, iwp_ex, lwp_fc, iwp_fc @@ -3010,13 +3031,11 @@ subroutine progcld6 & integer :: i, k, id, nf ! --- constant values -! real (kind=kind_phys), parameter :: xrc3 = 200. - real (kind=kind_phys), parameter :: xrc3 = 100. + real (kind=kind_phys), parameter :: xrc3 = 200. ! !===> ... begin here -! do nf=1,nf_clds do k=1,nlay do i=1,ix @@ -3065,6 +3084,7 @@ subroutine progcld6 & do k = 1, NLAY do i = 1, IX clwf(i,k) = clw(i,k,ntcw) + clw(i,k,ntiw) + clw(i,k,ntsw) + & + clw(i,k,ntrw) + cnvw(i,k) enddo enddo !> - Find top pressure for each cloud domain for given latitude. @@ -3091,8 +3111,7 @@ subroutine progcld6 & cwp(i,k) = max(0.0, clw(i,k,ntcw) * gfac * delp(i,k)) cip(i,k) = max(0.0, clw(i,k,ntiw) * gfac * delp(i,k)) crp(i,k) = max(0.0, clw(i,k,ntrw) * gfac * delp(i,k)) - csp(i,k) = max(0.0, (clw(i,k,ntsw)+clw(i,k,ntgl)) * & - & gfac * delp(i,k)) + csp(i,k) = max(0.0, clw(i,k,ntsw) * gfac * delp(i,k)) enddo enddo @@ -3123,33 +3142,56 @@ subroutine progcld6 & !> - Calculate layer cloud fraction. clwmin = 0.0 - do k = 1, NLAY-1 - do i = 1, IX - clwt = 1.0e-6 * (plyr(i,k)*0.001) + if (.not. lmfshal) then + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) - if (clwf(i,k) > clwt) then - onemrh= max( 1.e-10, 1.0-rhly(i,k) ) - clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + if (clwf(i,k) > clwt) then + + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) - if (.not. lmfshal) then tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) tem1 = 2000.0 / tem1 - else - tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan - if (lmfdeep2) then - tem1 = xrc3 / tem1 - else - tem1 = 100.0 / tem1 - endif - endif - value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) - tem2 = sqrt( sqrt(rhly(i,k)) ) - cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) - endif - enddo - enddo + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + else + do k = 1, NLAY-1 + do i = 1, IX + clwt = 1.0e-10 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + if(rhly(i,k) > 0.99) then + cldtot(i,k) = 1. + else + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + else + cldtot(i,k) = 0.0 + endif + enddo + enddo + endif endif ! if (uni_cld) then do k = 1, NLAY @@ -3164,7 +3206,8 @@ subroutine progcld6 & enddo enddo - ! What portion of water and ice contents is associated with the partly cloudy boxes + ! What portion of water and ice contents is associated with the + ! partly cloudy boxes do i = 1, IX do k = 1, NLAY-1 if (cldtot(i,k).ge.climit .and. cldtot(i,k).lt.ovcst) then @@ -3190,7 +3233,6 @@ subroutine progcld6 & enddo endif -! do k = 1, NLAY do i = 1, IX clouds(i,k,1) = cldtot(i,k) @@ -3224,6 +3266,19 @@ subroutine progcld6 & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -3241,7 +3296,6 @@ subroutine progcld6 & & clds, mtop, mbot & & ) -! return !............................................ @@ -3311,7 +3365,7 @@ subroutine progcld_thompson & ! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! -! gridkm : grid length in km ! +! gridkm (IX) : grid length in km ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! ! uni_cld : logical - true for cloud fraction from shoc ! @@ -3370,8 +3424,8 @@ subroutine progcld_thompson & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk - real(kind=kind_phys), dimension(:), intent(in) :: latdeg - real(kind=kind_phys), intent(in) :: julian, gridkm + real(kind=kind_phys), dimension(:), intent(in) :: latdeg, gridkm + real(kind=kind_phys), intent(in) :: julian integer, intent(in) :: yearlen ! --- outputs @@ -3445,14 +3499,14 @@ subroutine progcld_thompson & enddo !> - Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . -!> - Since using Thompson MP, assume 20 percent of snow is actually in +!> - Since using Thompson MP, assume 1 percent of snow is actually in !! ice sizes. do k = 1, NLAY-1 do i = 1, IX cwp(i,k) = max(0.0, clw(i,k,ntcw) * dz(i,k)*1.E6) crp(i,k) = 0.0 - snow_mass_factor = 0.85 + snow_mass_factor = 0.99 cip(i,k) = max(0.0, (clw(i,k,ntiw) & & + (1.0-snow_mass_factor)*clw(i,k,ntsw))*dz(i,k)*1.E6) if (re_snow(i,k) .gt. snow_max_radius)then @@ -3518,7 +3572,7 @@ subroutine progcld_thompson & endif call cal_cldfra3(cldfra1d, qv1d, qc1d, qi1d, qs1d, dz1d, & - & p1d, t1d, xland, gridkm, & + & p1d, t1d, xland, gridkm(i), & & .false., max_relh, 1, nlay, .false.) do k = 1, NLAY @@ -3592,6 +3646,19 @@ subroutine progcld_thompson & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -3989,6 +4056,19 @@ subroutine progclduni & alpha(:,:) = 0. endif + ! Revise alpha for exponential-random cloud overlap + ! Decorrelate layers when a clear layer follows a cloudy layer to enforce + ! random correlation between non-adjacent blocks of cloudy layers + if (iovr == 5) then + do k = 2, nLay + do i = 1, ix + if (clouds(i,k,1) == 0.0 .and. clouds(i,k-1,1) > 0.0) then + alpha(i,k) = 0.0 + endif + enddo + enddo + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -4532,16 +4612,16 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & DO k = kts,kte delz = MAX(100., dz(k)) - RH_00L = 0.74+MIN(0.25,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) - RH_00O = 0.82+MIN(0.17,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00L = 0.77+MIN(0.22,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) + RH_00O = 0.85+MIN(0.14,SQRT(1./(50.0+gridkm*gridkm*delz*0.01))) RHUM = rh(k) - if (qc(k).ge.1.E-5 .or. qi(k).ge.1.E-5 & - & .or. (qs(k).gt.1.E-5 .and. t(k).lt.273.)) then + if (qc(k).ge.1.E-6 .or. qi(k).ge.1.E-7 & + & .or. (qs(k).gt.1.E-6 .and. t(k).lt.273.)) then CLDFRA(K) = 1.0 elseif (((qc(k)+qi(k)).gt.1.E-10) .and. & - & ((qc(k)+qi(k)).lt.1.E-5)) then - CLDFRA(K) = MIN(0.99, 0.20*(10.0 + log10(qc(k)+qi(k)))) + & ((qc(k)+qi(k)).lt.1.E-6)) then + CLDFRA(K) = MIN(0.99, 0.1*(11.0 + log10(qc(k)+qi(k)))) else IF ((XLAND-1.5).GT.0.) THEN !--- Ocean @@ -4550,7 +4630,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & RH_00 = RH_00L ENDIF - tc = t(k) - 273.15 + tc = MAX(-80.0, t(k) - 273.15) if (tc .lt. -12.0) RH_00 = RH_00L if (tc .gt. 20.0) then @@ -4562,12 +4642,12 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & if (max_relh.gt.1.12 .or. (.NOT.(modify_qvapor)) ) then !..For HRRR model, the following look OK. RHUM = MIN(rh(k), 1.45) - RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+112.) + RH_00 = RH_00 + (1.45-RH_00)*(-12.0-tc)/(-12.0+85.) CLDFRA(K) = MAX(0.,1.0-SQRT((1.46-RHUM)/(1.46-RH_00))) else !..but for the GFS model, RH is way lower. RHUM = MIN(rh(k), 1.05) - RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+112.) + RH_00 = RH_00 + (1.05-RH_00)*(-12.0-tc)/(-12.0+85.) CLDFRA(K) = MAX(0.,1.0-SQRT((1.06-RHUM)/(1.06-RH_00))) endif endif @@ -4585,15 +4665,6 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, dz, & call adjust_cloudFinal(cldfra, qc, qi, rhoa, dz, kts,kte) - if (debug_flag .and. ndebug.lt.25) then - do k = kts,kte - write(6,'(a,i3,f9.2,f7.1,f7.2,f6.1,f6.3,f12.7,f12.7,f12.7)') & - & ' DEBUG-GT: ', k, p(k)*0.01, dz(k), t(k)-273.15, & - & rh(k)*100., cldfra(k), qc(k)*1.E3, qi(k)*1.E3, qs(k)*1.E3 - enddo - ndebug = ndebug + 1 - endif - !..Intended for cold start model runs, we use modify_qvapor to ensure that cloudy !.. areas are actually saturated such that the inserted clouds do not evaporate a !.. timestep later. @@ -4735,9 +4806,9 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, Dz1d, entrmnt,& k = k - 1 ENDDO - k_cldb = k_m12C + 5 + k_cldb = k_m12C + 3 in_cloud = .false. - k = k_m12C + 4 + k = k_m12C + 2 DO WHILE (.not. in_cloud .AND. k.gt.kbot) k_cldt = 0 if (cfr1d(k).ge.0.01) then @@ -4786,12 +4857,13 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) do k = k1, k2 tdz = tdz + dz(k) enddo - max_iwc = ABS(qvs(k2)-qvs(k1)) +! max_iwc = ABS(qvs(k2)-qvs(k1)) + max_iwc = MAX(0.0, qvs(k1)-qvs(k2)) do k = k1, k2 - max_iwc = MAX(1.E-5, max_iwc - (qi(k)+qs(k))) + max_iwc = MAX(1.E-6, max_iwc - (qi(k)+qs(k))) enddo - max_iwc = MIN(2.E-3, max_iwc) + max_iwc = MIN(1.E-4, max_iwc) this_dz = 0.0 do k = k1, k2 @@ -4801,7 +4873,7 @@ SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_iwc = max_iwc*this_dz/tdz - iwc = MAX(5.E-6, this_iwc*(1.-entr)) + iwc = MAX(1.E-6, this_iwc*(1.-entr)) if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.203.16) then qi(k) = qi(k) + cfr(k)*cfr(k)*iwc endif @@ -4826,13 +4898,14 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) do k = k1, k2 tdz = tdz + dz(k) enddo - max_lwc = ABS(qvs(k2)-qvs(k1)) +! max_lwc = ABS(qvs(k2)-qvs(k1)) + max_lwc = MAX(0.0, qvs(k1)-qvs(k2)) ! print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz do k = k1, k2 - max_lwc = MAX(1.E-5, max_lwc - qc(k)) + max_lwc = MAX(1.E-6, max_lwc - qc(k)) enddo - max_lwc = MIN(2.E-3, max_lwc) + max_lwc = MIN(1.E-4, max_lwc) this_dz = 0.0 do k = k1, k2 @@ -4842,8 +4915,8 @@ SUBROUTINE adjust_cloudH2O(cfr, qc, qvs,T,dz,entr, k1,k2,kts,kte) this_dz = this_dz + dz(k) endif this_lwc = max_lwc*this_dz/tdz - lwc = MAX(5.E-6, this_lwc*(1.-entr)) - if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.253.16) then + lwc = MAX(1.E-6, this_lwc*(1.-entr)) + if (cfr(k).gt.0.0.and.cfr(k).lt.1.0.and.T(k).ge.258.16) then qc(k) = qc(k) + cfr(k)*cfr(k)*lwc endif enddo @@ -4895,6 +4968,6 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte) END SUBROUTINE adjust_cloudFinal !........................................! - end module module_radiation_clouds ! + end module module_radiation_clouds !! @} !========================================! diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 066bcfbef..64afd0a35 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -247,10 +247,12 @@ subroutine sfc_init & if ( me == 0 ) then print *,' - Using Varying Surface Emissivity for lw' print *,' Requested data file "',semis_file,'" not found!' - print *,' Change to fixed surface emissivity = 1.0 !' endif + errmsg = 'module_radiation_surface: surface emissivity + & file not provided' + errflg = 1 + return - iemslw = 0 else close(NIRADSF) open (NIRADSF,file=semis_file,form='formatted',status='old') diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 89609c283..95bc0b059 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -284,7 +284,6 @@ module rrtmg_lw & con_amw, con_amo3 use mersenne_twister, only : random_setseed, random_number, & & random_stat -!mz use machine, only : kind_phys, & & im => kind_io4, rb => kind_phys @@ -635,31 +634,6 @@ subroutine rrtmg_lw_run & real (kind=kind_phys), dimension(:,:,:),intent(in):: & & aeraod, aerssa -!mz* HWRF -- OUTPUT from mcica_subcol_lw - real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: cldfmcl ! Cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: ciwpmcl ! In-cloud ice water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: clwpmcl ! In-cloud liquid water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: cswpmcl ! In-cloud snow water path (g/m2) - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=kind_phys),dimension(npts,nlay) :: relqmcl ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - real(kind=kind_phys),dimension(npts,nlay) :: reicmcl ! Cloud ice effective size (microns) - ! Dimensions: (ncol,nlay) - real(kind=kind_phys),dimension(npts,nlay) :: resnmcl ! Snow effective size (microns) - ! Dimensions: (ncol,nlay) - real(kind=kind_phys),dimension(ngptlw,npts,nlay) :: taucmcl ! In-cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=kind_phys),dimension(npts,nlay,nbands) :: tauaer ! Aerosol optical depth -! ! Dimensions: (ncol,nlay,nbndlw) -!mz* output from cldprmc - integer :: ncbands ! number of cloud spectral bands - real(kind=kind_phys),dimension(ngptlw,nlay) :: taucmc ! cloud optical depth [mcica] - ! Dimensions: (ngptlw,nlayers) -!mz - ! --- outputs: real (kind=kind_phys), dimension(:,:), intent(inout) :: hlwc real (kind=kind_phys), dimension(:,:), intent(inout) :: & @@ -681,11 +655,6 @@ subroutine rrtmg_lw_run & logical, intent(in) :: lslwr ! --- locals: -! mz* - Add height of each layer for exponential-random cloud overlap -! This will be derived below from the dzlyr in each layer - real (kind=kind_phys), dimension( npts,nlay ) :: hgt - real (kind=kind_phys) :: dzsum - real (kind=kind_phys), dimension(0:nlp1) :: cldfrc real (kind=kind_phys), dimension(0:nlay) :: totuflux, totdflux, & @@ -699,11 +668,6 @@ subroutine rrtmg_lw_run & & selffac, selffrac, forfac, forfrac, minorfrac, scaleminor, & & scaleminorn2, temcol, dz -!mz* - real(kind=rb),dimension(0:nlay,nbands) :: planklay,planklev - real(kind=rb),dimension(0:nlay) :: pz - -! real(kind=rb) :: plankbnd(nbndlw) real (kind=kind_phys), dimension(nbands,0:nlay) :: pklev, pklay real (kind=kind_phys), dimension(nlay,nbands) :: htrb @@ -711,26 +675,7 @@ subroutine rrtmg_lw_run & real (kind=kind_phys), dimension(nbands,npts,nlay) :: taucld3 real (kind=kind_phys), dimension(ngptlw,nlay) :: fracs, tautot real (kind=kind_phys), dimension(nlay,ngptlw) :: fracs_r -!mz rtrnmc_mcica - real (kind=kind_phys), dimension(nlay,ngptlw) :: taut -!mz* Atmosphere/clouds - cldprop - real(kind=kind_phys), dimension(ngptlw,nlay) :: cldfmc, & - & cldfmc_save ! cloud fraction [mcica] - ! Dimensions: (ngptlw,nlay) - real(kind=kind_phys), dimension(ngptlw,nlay) :: ciwpmc ! in-cloud ice water path [mcica] - ! Dimensions: (ngptlw,nlay) - real(kind=kind_phys), dimension(ngptlw,nlay) :: clwpmc ! in-cloud liquid water path [mcica] - ! Dimensions: (ngptlw,nlay) - real(kind=kind_phys), dimension(ngptlw,nlay) :: cswpmc ! in-cloud snow path [mcica] - ! Dimensions: (ngptlw,nlay) - real(kind=kind_phys), dimension(nlay) :: relqmc ! liquid particle effective radius (microns) - ! Dimensions: (nlay) - real(kind=kind_phys), dimension(nlay) :: reicmc ! ice particle effective size (microns) - ! Dimensions: (nlay) - real(kind=kind_phys), dimension(nlay) :: resnmc ! snow effective size (microns) - ! Dimensions: (nlay) - - + real(kind=kind_phys), dimension(ngptlw,nlay) :: cldfmc real (kind=kind_phys), dimension(nbands) :: semiss, secdiff ! --- column amount of absorbing gases: @@ -752,8 +697,7 @@ subroutine rrtmg_lw_run & integer, dimension(npts) :: ipseed integer, dimension(nlay) :: jp, jt, jt1, indself, indfor, indminor integer :: laytrop, iplon, i, j, k, k1 - ! mz* added local arrays for RRTMG - integer :: irng, permuteseed,ig + integer :: ig integer :: inflglw, iceflglw, liqflglw logical :: lcf1 integer :: istart ! beginning band of calculation @@ -850,43 +794,6 @@ subroutine rrtmg_lw_run & stemp = sfgtmp(iplon) ! surface ground temp if (iovr == 3) delgth= de_lgth(iplon) ! clouds decorr-length -! mz*: HWRF - if (iovr == 4 ) then - -!Add layer height needed for exponential (icld=4) and -! exponential-random (icld=5) overlap options - - !iplon = 1 - irng = 0 - permuteseed = 150 - -!mz* Derive height - dzsum =0.0 - do k = 1,nlay - hgt(iplon,k)= dzsum+0.5*dzlyr(iplon,k)*1000. !km->m - dzsum = dzsum+ dzlyr(iplon,k)*1000. - enddo - -! Zero out cloud optical properties here; not used when passing physical properties -! to radiation and taucld is calculated in radiation - do k = 1, nlay - do j = 1, nbands - taucld3(j,iplon,k) = 0.0 - enddo - enddo - - call mcica_subcol_lw(1, iplon, nlay, iovr, permuteseed, & - & irng, plyr, hgt, & - & cld_cf, cld_iwp, cld_lwp,cld_swp, & - & cld_ref_ice, cld_ref_liq, & - & cld_ref_snow, taucld3, & - & cldfmcl, & !--output - & ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, & - & resnmcl, taucmcl) - - endif -!mz* end - !> -# Prepare atmospheric profile for use in rrtm. ! the vertical index of internal array is from surface to top @@ -987,23 +894,6 @@ subroutine rrtmg_lw_run & cda3(k) = cld_swp(iplon,k1) cda4(k) = cld_ref_snow(iplon,k1) enddo - ! HWRF RRMTG - if (iovr == 4) then !mz HWRF - do k = 1, nlay - k1 = nlp1 - k - do ig = 1, ngptlw - cldfmc(ig,k) = cldfmcl(ig,iplon,k1) - taucmc(ig,k) = taucmcl(ig,iplon,k1) - ciwpmc(ig,k) = ciwpmcl(ig,iplon,k1) - clwpmc(ig,k) = clwpmcl(ig,iplon,k1) - !mz cswpmc(ig,k) = cswpmcl(ig,iplon,k1) - cswpmc(ig,k) = 0.0 - enddo - reicmc(k) = reicmcl(iplon,k1) - relqmc(k) = relqmcl(iplon,k1) - resnmc(k) = resnmcl(iplon,k1) - enddo - endif else ! use diagnostic cloud method do k = 1, nlay k1 = nlp1 - k @@ -1111,24 +1001,6 @@ subroutine rrtmg_lw_run & cda3(k) = cld_swp(iplon,k) cda4(k) = cld_ref_snow(iplon,k) enddo - if (iovr == 4) then -!mz* Move incoming GCM cloud arrays to RRTMG cloud arrays. -!For GCM input, incoming reicmcl is defined based on selected -!ice parameterization (inflglw) - do k = 1, nlay - do ig = 1, ngptlw - cldfmc(ig,k) = cldfmcl(ig,iplon,k) - taucmc(ig,k) = taucmcl(ig,iplon,k) - ciwpmc(ig,k) = ciwpmcl(ig,iplon,k) - clwpmc(ig,k) = clwpmcl(ig,iplon,k) - !mz cswpmc(ig,k) = cswpmcl(ig,iplon,k) - cswpmc(ig,k) = 0.0 - enddo - reicmc(k) = reicmcl(iplon,k) - relqmc(k) = relqmcl(iplon,k) - resnmc(k) = resnmcl(iplon,k) - enddo - endif else ! use diagnostic cloud method do k = 1, nlay cldfrc(k)= cld_cf(iplon,k) @@ -1204,15 +1076,6 @@ subroutine rrtmg_lw_run & if ( lcf1 ) then - !mz* for HWRF, save cldfmc with mcica - if (iovr == 4) then - do k = 1, nlay - do ig = 1, ngptlw - cldfmc_save(ig,k)=cldfmc (ig,k) - enddo - enddo - endif - call cldprop & ! --- inputs: & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & @@ -1221,15 +1084,6 @@ subroutine rrtmg_lw_run & & cldfmc, taucld & & ) - if (iovr == 4) then - !mz for HWRF, still using mcica cldfmc - do k = 1, nlay - do ig = 1, ngptlw - cldfmc(ig,k)=cldfmc_save(ig,k) - enddo - enddo - endif - ! --- ... save computed layer cloud optical depth for output ! rrtm band-7 is apprx 10mu channel (or use spectral mean of bands 6-8) @@ -1249,16 +1103,6 @@ subroutine rrtmg_lw_run & taucld = f_zero endif -!mz* HWRF: calculate taucmc with mcica - if (iovr == 4) then - call cldprmc(nlay, inflglw, iceflglw, liqflglw, & - & cldfmc, ciwpmc, & - & clwpmc, cswpmc, reicmc, relqmc, resnmc, & - & ncbands, taucmc, errmsg, errflg) - ! return immediately if cldprmc throws an error - if (errflg/=0) return - endif - ! if (lprnt) then ! print *,' after cldprop' ! print *,' clwp',clwp @@ -1519,7 +1363,8 @@ subroutine rlwinit & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud (isubcol>0 only) ! ! =3: decorrelation-length overlap (for isubclw>0 only) ! -! =4: exponential overlap cloud +! =4: exponential cloud overlap (AER) ! +! =5: exponential-random cloud overlap (AER) ! ! ! ! ******************************************************************* ! ! original code description ! @@ -1563,7 +1408,7 @@ subroutine rlwinit & ! !===> ... begin here ! - if ( iovr<0 .or. iovr>4 ) then + if ( iovr<0 .or. iovr>5 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVR=',iovr,' in RLWINIT !!' stop @@ -1992,8 +1837,6 @@ subroutine cldprop & ! --- ... call sub-column cloud generator -!mz* - if (iovr .ne. 4) then call mcica_subcol & ! --- inputs: & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & @@ -2010,7 +1853,6 @@ subroutine cldprop & endif enddo enddo - endif !iovr endif ! end if_isubclw_block @@ -2055,6 +1897,7 @@ subroutine mcica_subcol & ! other control flags from module variables: ! ! iovr : control flag for cloud overlapping method ! ! =0:random; =1:maximum/random: =2:maximum; =3:decorr ! +! =4:exponential; =5:exponential-random ! ! ! ! ===================== end of definitions ==================== ! @@ -7040,1023 +6883,6 @@ end subroutine taugb16 ! .................................. end subroutine taumol !! @} -!----------------------------------- - -!mz* exponential cloud overlapping subroutines -!------------------------------------------------------------------ -! Public subroutines -!------------------------------------------------------------------ -! mz* - Add height needed for exponential and exponential-random cloud overlap methods (icld=4 and 5, respectively) - subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, & - & irng, play, hgt, & - & cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, & - & cldfmcl, & - & ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, & - & resnmcl, taucmcl) - - use machine, only : im => kind_io4, rb => kind_phys -! ----- Input ----- -! Control - integer(kind=im), intent(in) :: iplon ! column/longitude index - integer(kind=im), intent(in) :: ncol ! number of columns - integer(kind=im), intent(in) :: nlay ! number of model layers - integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, - ! permute the seed between each call. - ! between calls for LW and SW, recommended - ! permuteseed differes by 'ngpt' - integer(kind=im), intent(inout) :: irng ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne - ! Twister - -! Atmosphere - real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - -! mji - Add height - real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) - ! Dimensions: (ncol,nlay) - -! Atmosphere/clouds - cldprop - real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth - ! Dimensions: (nbndlw,ncol,nlay) -! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo - ! Dimensions: (nbndlw,ncol,nlay) -! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter - ! Dimensions: (nbndlw,ncol,nlay) - real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: res(:,:) ! snow particle size - ! Dimensions: (ncol,nlay) - -! ----- Output ----- -! Atmosphere/clouds - cldprmc [mcica] - real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow path [mcica] - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] -!mz* - ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] - ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] - ! Dimensions: (ngptlw,ncol,nlay) -! ----- Local ----- - -! Stochastic cloud generator variables [mcica] - integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals) - integer(kind=im) :: ilev ! loop index - - real(kind=rb) :: pmid(ncol, nlay) ! layer pressures (Pa) -! real(kind=rb) :: pdel(ncol, nlay) ! layer pressure thickness (Pa) -! real(kind=rb) :: qi(ncol, nlay) ! ice water (specific humidity) -! real(kind=rb) :: ql(ncol, nlay) ! liq water (specific humidity) - -! Return if clear sky - if (icld.eq.0) return - -! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns - - -! Pass particle sizes to new arrays, no subcolumns for these properties yet -! Convert pressures from mb to Pa - - reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) - relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) - resnmcl(:ncol,:nlay) = res(:ncol,:nlay) - pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb - -! Generate the stochastic subcolumns of cloud optical properties for -! the longwave - call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, & - & pmid, hgt, cldfrac, clwp, ciwp, cswp, tauc, & - & cldfmcl, clwpmcl, ciwpmcl, cswpmcl, & - & taucmcl, permuteseed) - - end subroutine mcica_subcol_lw -!------------------------------------------------------------------------------------------------- - subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, & - & irng, pmid, hgt, cld, clwp, ciwp, cswp, tauc, & - & cld_stoch, clwp_stoch, ciwp_stoch, & - & cswp_stoch, tauc_stoch, changeSeed) -!------------------------------------------------------------------------------------------------- -!------------------------------------------------------------------------------------------------- -! Contact: Cecile Hannay (hannay@ucar.edu) -! -! Original code: Based on Raisanen et al., QJRMS, 2004. -! -! Modifications: -! 1) Generalized for use with RRTMG and added Mersenne Twister as the default -! random number generator, which can be changed to the optional kissvec random number generator -! with flag 'irng'. Some extra functionality has been commented or removed. -! Michael J. Iacono, AER, Inc., February 2007 -! 2) Activated exponential and exponential/random cloud overlap method -! Michael J. Iacono, AER, November 2017 -! -! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. -! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one -! and uniform cloud liquid and cloud ice concentration. -! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer -! and obeys an overlap assumption in the vertical. -! -! Overlap assumption: -! The cloud are consistent with 5 overlap assumptions: random, maximum, maximum-random, exponential and exponential random. -! The default option is maximum-random (option 2) -! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap, 5=exp/random -! This is set with the variable "overlap" -! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) -! -! Seed: -! If the stochastic cloud generator is called several times during the same timestep, -! one should change the seed between the call to insure that the -! subcolumns are different. -! This is done by changing the argument 'changeSeed' -! For example, if one wants to create a set of columns for the -! shortwave and another set for the longwave , -! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call - -! PDF assumption: -! We can use arbitrary complicated PDFS. -! In the present version, we produce homogeneuous clouds (the simplest case). -! Future developments include using the PDF scheme of Ben Johnson. -! -! History file: -! Option to add diagnostics variables in the history file. (using FINCL in the namelist) -! nsubcol = number of subcolumns -! overlap = overlap type (1-3) -! Zo = length scale -! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) -! CLDLIQ_S = mean of the subcolumn cloud water -! CLDICE_S = mean of the subcolumn cloud ice -! -! Note: -! Here: we force that the cloud condensate to be consistent with the cloud fraction -! i.e we only have cloud condensate when the cell is cloudy. -! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations -! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction -! without cloud condensate or the opposite). -!----------------------------------------------------------------- - - use mcica_random_numbers -! The Mersenne Twister random number engine - use MersenneTwister, only: randomNumberSequence, & - & new_RandomNumberSequence, getRandomReal - use machine ,only : im => kind_io4, rb => kind_phys - - type(randomNumberSequence) :: randomNumbers - -! -- Arguments - - integer(kind=im), intent(in) :: ncol ! number of columns - integer(kind=im), intent(in) :: nlay ! number of layers - integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(inout) :: irng ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne Twister - integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) - integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed - -! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state - real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) - ! Dimensions: (ncol,nlay) - - real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth - ! Dimensions:(nbndlw,ncol,nlay) -! real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo - ! Dimensions: (nbndlw,ncol,nlay) - ! inactive - for future expansion -! real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter - ! Dimensions: (nbndlw,ncol,nlay) - ! inactive - for future expansion - - real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow path - ! Dimensions: (ngptlw,ncol,nlay) - real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth - ! Dimensions: (ngptlw,ncol,nlay) -! real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo - ! Dimensions: (ngptlw,ncol,nlay) - ! inactive - for future expansion -! real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter - ! Dimensions: (ngptlw,ncol,nlay) - ! inactive - for future expansion - -! -- Local variables - real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction - -! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive -! real(kind=rb) :: mean_cld_stoch(ncol, nlay) ! cloud fraction -! real(kind=rb) :: mean_clwp_stoch(ncol, nlay) ! cloud water -! real(kind=rb) :: mean_ciwp_stoch(ncol, nlay) ! cloud ice -! real(kind=rb) :: mean_tauc_stoch(ncol, nlay) ! cloud optical depth -! real(kind=rb) :: mean_ssac_stoch(ncol, nlay) ! cloud single scattering albedo -! real(kind=rb) :: mean_asmc_stoch(ncol, nlay) ! cloud asymmetry parameter - -! Set overlap - integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, - ! 3 = maximum overlap, 4 = exponential, - ! 5 = exponential-random - real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) - real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter - -! Constants (min value for cloud fraction and cloud water and ice) - real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction -! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) - -! Variables related to random number and seed - real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 !random numbers - integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 !seed to create random number (kissvec) - real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) - integer(kind=im) :: iseed ! seed to create random number (Mersenne Teister) - real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) - -! Flag to identify cloud fraction in subcolumns - logical, dimension(nsubcol, ncol, nlay) :: iscloudy ! flag that says whether a gridbox is cloudy - -! Indices - integer(kind=im) :: ilev, isubcol, i, n ! indices - -!------------------------------------------------------------------- - -! Check that irng is in bounds; if not, set to default - if (irng .ne. 0) irng = 1 - -! Pass input cloud overlap setting to local variable - overlap = icld - -! Ensure that cloud fractions are in bounds - do ilev = 1, nlay - do i = 1, ncol - cldf(i,ilev) = cld(i,ilev) - if (cldf(i,ilev) < cldmin) then - cldf(i,ilev) = 0._rb - endif - enddo - enddo - -! ----- Create seed -------- - -! Advance randum number generator by changeseed values - if (irng.eq.0) then -! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. -! Must use pmid from bottom four layers. - do i=1,ncol - if (pmid(i,1).lt.pmid(i,2)) then - stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID & - & FROM BOTTOM FOUR LAYERS.' - endif - seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im - seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im - seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im - seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im - enddo - do i=1,changeSeed - call kissvec(seed1, seed2, seed3, seed4, rand_num) - enddo - elseif (irng.eq.1) then - randomNumbers = new_RandomNumberSequence(seed = changeSeed) - endif - -! ------ Apply overlap assumption -------- - -! generate the random numbers - - select case (overlap) - - case(1) -! Random overlap -! i) pick a random value at every level - - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) ! we get different random number for each level - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - case(2) -! Maximum-Random overlap -! i) pick a random number for top layer. -! ii) walk down the column: -! - if the layer above is cloudy, we use the same random number than in the layer above -! - if the layer above is clear, we use a new random number - - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - do ilev = 2,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) )& - & then - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) - else - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb & - & - cldf(i,ilev-1)) - endif - enddo - enddo - enddo - - case(3) -! Maximum overlap -! i) pick the same random numebr at every level - - if (irng.eq.0) then - do isubcol = 1,nsubcol - call kissvec(seed1, seed2, seed3, seed4, rand_num) - do ilev = 1,nlay - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - rand_num_mt = getRandomReal(randomNumbers) - do ilev = 1, nlay - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - -! mji - Activate exponential cloud overlap option - case(4) - ! Exponential overlap: weighting between maximum and random overlap increases with the distance. - ! The random numbers for exponential overlap verify: - ! j=1 RAN(j)=RND1 - ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) - ! RAN(j) = RND2 - ! alpha is obtained from the equation - ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale - - ! compute alpha - do i = 1, ncol - alpha(i, 1) = 0._rb - do ilev = 2,nlay - alpha(i, ilev) = exp( -( hgt (i, ilev) - & - & hgt (i, ilev-1)) / Zo) - enddo - enddo - - ! generate 2 streams of random numbers - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol, :, ilev) = rand_num - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF2(isubcol, :, ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - rand_num_mt = getRandomReal(randomNumbers) - CDF2(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - ! generate random numbers - do ilev = 2,nlay - where (CDF2(:, :, ilev) < spread(alpha (:,ilev), & - & dim=1,nCopies=nsubcol) ) - CDF(:,:,ilev) = CDF(:,:,ilev-1) - end where - end do - -! Activate exponential-random cloud overlap option - case(5) - ! Exponential-random overlap: -!mz* call wrf_error_fatal("Cloud Overlap case 5: ER has not yet & -! been implemented. Stopping...") - - end select - -! -- generate subcolumns for homogeneous clouds ----- - do ilev = 1,nlay - iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - & - & spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) - enddo - -! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; -! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; -! where there is a cloud, define the subcolumn cloud properties, -! otherwise set these to zero - - do ilev = 1,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if (iscloudy(isubcol,i,ilev) ) then - cld_stoch(isubcol,i,ilev) = 1._rb - clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) - ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) -!mz -! cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) - cswp_stoch(isubcol,i,ilev) = 0._rb - n = ngb(isubcol) - tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) -! ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) -! asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) - else - cld_stoch(isubcol,i,ilev) = 0._rb - clwp_stoch(isubcol,i,ilev) = 0._rb - ciwp_stoch(isubcol,i,ilev) = 0._rb - cswp_stoch(isubcol,i,ilev) = 0._rb - tauc_stoch(isubcol,i,ilev) = 0._rb -! ssac_stoch(isubcol,i,ilev) = 1._rb -! asmc_stoch(isubcol,i,ilev) = 1._rb - endif - enddo - enddo - enddo - -! -- compute the means of the subcolumns --- -! mean_cld_stoch(:,:) = 0._rb -! mean_clwp_stoch(:,:) = 0._rb -! mean_ciwp_stoch(:,:) = 0._rb -! mean_tauc_stoch(:,:) = 0._rb -! mean_ssac_stoch(:,:) = 0._rb -! mean_asmc_stoch(:,:) = 0._rb -! do i = 1, nsubcol -! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) -! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) -! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) -! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) -! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) -! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) -! end do -! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol -! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol -! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol -! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol -! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol -! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol - - end subroutine generate_stochastic_clouds - -!------------------------------------------------------------------ -! Private subroutines -!------------------------------------------------------------------ - -!----------------------------------------------------------------- - subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) -!---------------------------------------------------------------- - -! public domain code -! made available from http://www.fortran.com/ -! downloaded by pjr on 03/16/04 for NCAR CAM -! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 - -! The KISS (Keep It Simple Stupid) random number generator. Combines: -! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. -! (2) A 3-shift shift-register generator, period 2^32-1, -! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 -! Overall period>2^123; - real(kind=rb), dimension(:), intent(inout) :: ran_arr - integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3& - & ,seed4 - integer(kind=im) :: i,sz,kiss - integer(kind=im) :: m, k, n - -! inline function - m(k, n) = ieor (k, ishft (k, n) ) - - sz = size(ran_arr) - do i = 1, sz - seed1(i) = 69069_im * seed1(i) + 1327217885_im - seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) - seed3(i) = 18000_im * iand (seed3(i), 65535_im) + & - & ishft (seed3(i), - 16_im) - seed4(i) = 30903_im * iand (seed4(i), 65535_im) + & - & ishft (seed4(i), - 16_im) - kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) - ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb - end do - - end subroutine kissvec -! - subroutine rtrnmc_mcica(nlayers, istart, iend, iout, pz, semiss, & - & ncbands, cldfmc, taucmc, planklay, planklev, &!plankbnd, & - & pwvcm, fracs, taut, & - & totuflux, totdflux, htr, & - & totuclfl, totdclfl, htrc ) -!--------------------------------------------------------------- -! -! Original version: E. J. Mlawer, et al. RRTM_V3.0 -! Revision for GCMs: Michael J. Iacono; October, 2002 -! Revision for F90: Michael J. Iacono; June, 2006 -! -! This program calculates the upward fluxes, downward fluxes, and -! heating rates for an arbitrary clear or cloudy atmosphere. The input -! to this program is the atmospheric profile, all Planck function -! information, and the cloud fraction by layer. A variable diffusivity -! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 -! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of -! the column water vapor, and other bands use a value of 1.66. The Gaussian -! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that -! use of the emissivity angle for the flux integration can cause errors of -! 1 to 4 W/m2 within cloudy layers. -! Clouds are treated with the McICA stochastic approach and maximum-random -! cloud overlap. -!*************************************************************************** - -! ------- Declarations ------- - -! ----- Input ----- - integer(kind=im), intent(in) :: nlayers ! total number of layers - integer(kind=im), intent(in) :: istart ! beginning band of calculation - integer(kind=im), intent(in) :: iend ! ending band of calculation - integer(kind=im), intent(in) :: iout ! output option flag - -! Atmosphere - real(kind=rb), intent(in) :: pz(0:) ! level (interface) pressures (hPa, mb) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(in) :: pwvcm ! precipitable water vapor (cm) - real(kind=rb), intent(in) :: semiss(:) ! lw surface emissivity - ! Dimensions: (nbndlw) -!mz - real(kind=rb), intent(in) :: planklay(0:,:) ! - ! Dimensions: (nlayers,nbndlw) - real(kind=rb), intent(in) :: planklev(0:,:) ! - ! Dimensions: (0:nlayers,nbndlw) -! real(kind=rb), intent(in) :: plankbnd(:) ! - ! Dimensions: (nbndlw) - real(kind=rb), intent(in) :: fracs(:,:) ! - ! Dimensions: (nlayers,ngptw) - real(kind=rb), intent(in) :: taut(:,:) ! gaseous + aerosol optical depths - ! Dimensions: (nlayers,ngptlw) - -! Clouds - integer(kind=im), intent(in) :: ncbands ! number of cloud spectral bands - real(kind=rb), intent(in) :: cldfmc(:,:) ! layer cloud fraction [mcica] - ! Dimensions: (ngptlw,nlayers) - real(kind=rb), intent(in) :: taucmc(:,:) ! layer cloud optical depth [mcica] - ! Dimensions: (ngptlw,nlayers) - -! ----- Output ----- - real(kind=rb), intent(out) :: totuflux(0:) ! upward longwave flux (w/m2) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(out) :: totdflux(0:) ! downward longwave flux (w/m2) - ! Dimensions: (0:nlayers) -!mz* real(kind=rb), intent(out) :: fnet(0:) ! net longwave flux (w/m2) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(out) :: htr(:) -!mz real(kind=rb), intent(out) :: htr(0:) ! longwave heating rate (k/day) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(out) :: totuclfl(0:) ! clear sky upward longwave flux (w/m2) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(out) :: totdclfl(0:) ! clear sky downward longwave flux (w/m2) - ! Dimensions: (0:nlayers) -!mz*real(kind=rb), intent(out) :: fnetc(0:) ! clear sky net longwave flux (w/m2) - ! Dimensions: (0:nlayers) - real(kind=rb), intent(out) :: htrc(:) -! real(kind=rb), intent(out) :: htrc(0:) ! clear sky longwave heating rate (k/day) - ! Dimensions: (0:nlayers) - -! ----- Local ----- -! Declarations for radiative transfer - real (kind=kind_phys), dimension(0:nlayers) :: fnet, fnetc - real(kind=rb) :: abscld(nlayers,ngptlw) - real(kind=rb) :: atot(nlayers) - real(kind=rb) :: atrans(nlayers) - real(kind=rb) :: bbugas(nlayers) - real(kind=rb) :: bbutot(nlayers) - real(kind=rb) :: clrurad(0:nlayers) - real(kind=rb) :: clrdrad(0:nlayers) - real(kind=rb) :: efclfrac(nlayers,ngptlw) - real(kind=rb) :: uflux(0:nlayers) - real(kind=rb) :: dflux(0:nlayers) - real(kind=rb) :: urad(0:nlayers) - real(kind=rb) :: drad(0:nlayers) - real(kind=rb) :: uclfl(0:nlayers) - real(kind=rb) :: dclfl(0:nlayers) - real(kind=rb) :: odcld(nlayers,ngptlw) - - - real(kind=rb) :: secdiff(nbands) ! secant of diffusivity angle - real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup,& - & dplankdn - real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc - real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, & - & tausfac - real(kind=rb) :: rad0, reflect, radlu, radclru - - integer(kind=im) :: icldlyr(nlayers) ! flag for cloud in layer - integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig ! loop indices - integer(kind=im) :: igc ! g-point interval counter - integer(kind=im) :: iclddn ! flag for cloud in down path - integer(kind=im) :: ittot, itgas, itr ! lookup table indices -!mz* - real (kind=kind_phys), parameter :: rec_6 = 0.166667 - ! The cumulative sum of new g-points for each band - integer(kind=im) :: ngs(nbands) - ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138, & - & 140/) - -! ------- Definitions ------- -! input -! nlayers ! number of model layers -! ngptlw ! total number of g-point subintervals -! nbndlw ! number of longwave spectral bands -! ncbands ! number of spectral bands for clouds -! secdiff ! diffusivity angle -! wtdiff ! weight for radiance to flux conversion -! pavel ! layer pressures (mb) -! pz ! level (interface) pressures (mb) -! tavel ! layer temperatures (k) -! tz ! level (interface) temperatures(mb) -! tbound ! surface temperature (k) -! cldfrac ! layer cloud fraction -! taucloud ! layer cloud optical depth -! itr ! integer look-up table index -! icldlyr ! flag for cloudy layers -! iclddn ! flag for cloud in column at any layer -! semiss ! surface emissivities for each band -! reflect ! surface reflectance -! bpade ! 1/(pade constant) -! tau_tbl ! clear sky optical depth look-up table -! exp_tbl ! exponential look-up table for transmittance -! tfn_tbl ! tau transition function look-up table - -! local -! atrans ! gaseous absorptivity -! abscld ! cloud absorptivity -! atot ! combined gaseous and cloud absorptivity -! odclr ! clear sky (gaseous) optical depth -! odcld ! cloud optical depth -! odtot ! optical depth of gas and cloud -! tfacgas ! gas-only pade factor, used for planck fn -! tfactot ! gas and cloud pade factor, used for planck fn -! bbdgas ! gas-only planck function for downward rt -! bbugas ! gas-only planck function for upward rt -! bbdtot ! gas and cloud planck function for downward rt -! bbutot ! gas and cloud planck function for upward calc. -! gassrc ! source radiance due to gas only -! efclfrac ! effective cloud fraction -! radlu ! spectrally summed upward radiance -! radclru ! spectrally summed clear sky upward radiance -! urad ! upward radiance by layer -! clrurad ! clear sky upward radiance by layer -! radld ! spectrally summed downward radiance -! radclrd ! spectrally summed clear sky downward radiance -! drad ! downward radiance by layer -! clrdrad ! clear sky downward radiance by layer - - -! output -! totuflux ! upward longwave flux (w/m2) -! totdflux ! downward longwave flux (w/m2) -! fnet ! net longwave flux (w/m2) -! htr ! longwave heating rate (k/day) -! totuclfl ! clear sky upward longwave flux (w/m2) -! totdclfl ! clear sky downward longwave flux (w/m2) -! fnetc ! clear sky net longwave flux (w/m2) -! htrc ! clear sky longwave heating rate (k/day) - - -!jm not thread safe hvrrtc = '$Revision: 1.3 $' - - do ibnd = 1,nbands!mz*nbndlw - if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then - secdiff(ibnd) = 1.66_rb - else - secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm) - if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb - if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb - endif - enddo - - urad(0) = 0.0_rb - drad(0) = 0.0_rb - totuflux(0) = 0.0_rb - totdflux(0) = 0.0_rb - clrurad(0) = 0.0_rb - clrdrad(0) = 0.0_rb - totuclfl(0) = 0.0_rb - totdclfl(0) = 0.0_rb - - do lay = 1, nlayers - urad(lay) = 0.0_rb - drad(lay) = 0.0_rb - totuflux(lay) = 0.0_rb - totdflux(lay) = 0.0_rb - clrurad(lay) = 0.0_rb - clrdrad(lay) = 0.0_rb - totuclfl(lay) = 0.0_rb - totdclfl(lay) = 0.0_rb - icldlyr(lay) = 0 - -! Change to band loop? - do ig = 1, ngptlw - if (cldfmc(ig,lay) .eq. 1._rb) then - ib = ngb(ig) - odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay) - transcld = exp(-odcld(lay,ig)) - abscld(lay,ig) = 1._rb - transcld - efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay) - icldlyr(lay) = 1 - else - odcld(lay,ig) = 0.0_rb - abscld(lay,ig) = 0.0_rb - efclfrac(lay,ig) = 0.0_rb - endif - enddo - - enddo - - igc = 1 -! Loop over frequency bands. - do iband = istart, iend - -! Reinitialize g-point counter for each band if output for each band is requested. - if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1 - -! Loop over g-channels. - 1000 continue - -! Radiative transfer starts here. - radld = 0._rb - radclrd = 0._rb - iclddn = 0 - -! Downward radiative transfer loop. - - do lev = nlayers, 1, -1 - plfrac = fracs(lev,igc) - blay = planklay(lev,iband) - dplankup = planklev(lev,iband) - blay - dplankdn = planklev(lev-1,iband) - blay - odepth = secdiff(iband) * taut(lev,igc) - if (odepth .lt. 0.0_rb) odepth = 0.0_rb -! Cloudy layer - if (icldlyr(lev).eq.1) then - iclddn = 1 - odtot = odepth + odcld(lev,igc) - if (odtot .lt. 0.06_rb) then - atrans(lev) = odepth - 0.5_rb*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - - atot(lev) = odtot - 0.5_rb*odtot*odtot - odtot_rec = rec_6*odtot - bbdtot = plfrac * (blay+dplankdn*odtot_rec) - bbd = plfrac*(blay+dplankdn*odepth_rec) - radld = radld - radld * (atrans(lev) + & - & efclfrac(lev,igc) * (1. - atrans(lev))) + & - & gassrc + cldfmc(igc,lev) * & - & (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - - bbugas(lev) = plfrac * (blay+dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay+dplankup*odtot_rec) - - elseif (odepth .le. 0.06_rb) then - atrans(lev) = odepth - 0.5_rb*odepth*odepth - odepth_rec = rec_6*odepth - gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev) - - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_rb - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+dplankdn*odepth_rec) - atot(lev) = 1. - exp_tbl(ittot) - - radld = radld - radld * (atrans(lev) + & - & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & - & gassrc + cldfmc(igc,lev) * & - & (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - - bbugas(lev) = plfrac * (blay + dplankup*odepth_rec) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - - else - - tblind = odepth/(bpade+odepth) - itgas = tblint*tblind+0.5_rb - odepth = tau_tbl(itgas) - atrans(lev) = 1._rb - exp_tbl(itgas) - tfacgas = tfn_tbl(itgas) - gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) - - odtot = odepth + odcld(lev,igc) - tblind = odtot/(bpade+odtot) - ittot = tblint*tblind + 0.5_rb - tfactot = tfn_tbl(ittot) - bbdtot = plfrac * (blay + tfactot*dplankdn) - bbd = plfrac*(blay+tfacgas*dplankdn) - atot(lev) = 1._rb - exp_tbl(ittot) - - radld = radld - radld * (atrans(lev) + & - & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & - & gassrc + cldfmc(igc,lev) * & - & (bbdtot * atot(lev) - gassrc) - drad(lev-1) = drad(lev-1) + radld - bbugas(lev) = plfrac * (blay + tfacgas * dplankup) - bbutot(lev) = plfrac * (blay + tfactot * dplankup) - endif -! Clear layer - else - if (odepth .le. 0.06_rb) then - atrans(lev) = odepth-0.5_rb*odepth*odepth - odepth = rec_6*odepth - bbd = plfrac*(blay+dplankdn*odepth) - bbugas(lev) = plfrac*(blay+dplankup*odepth) - else - tblind = odepth/(bpade+odepth) - itr = tblint*tblind+0.5_rb - transc = exp_tbl(itr) - atrans(lev) = 1._rb-transc - tausfac = tfn_tbl(itr) - bbd = plfrac*(blay+tausfac*dplankdn) - bbugas(lev) = plfrac * (blay + tausfac * dplankup) - endif - radld = radld + (bbd-radld)*atrans(lev) - drad(lev-1) = drad(lev-1) + radld - endif -! Set clear sky stream to total sky stream as long as layers -! remain clear. Streams diverge when a cloud is reached (iclddn=1), -! and clear sky stream must be computed separately from that point. - if (iclddn.eq.1) then - radclrd = radclrd + (bbd-radclrd) * atrans(lev) - clrdrad(lev-1) = clrdrad(lev-1) + radclrd - else - radclrd = radld - clrdrad(lev-1) = drad(lev-1) - endif - enddo - -! Spectral emissivity & reflectance -! Include the contribution of spectrally varying longwave emissivity -! and reflection from the surface to the upward radiative transfer. -! Note: Spectral and Lambertian reflection are identical for the -! diffusivity angle flux integration used here. - -!mz* -! rad0 = fracs(1,igc) * plankbnd(iband) - rad0 = semiss(iband) * fracs(1,igc) * planklay(0,iband) -!mz -! Add in specular reflection of surface downward radiance. - reflect = 1._rb - semiss(iband) - radlu = rad0 + reflect * radld - radclru = rad0 + reflect * radclrd - - -! Upward radiative transfer loop. - urad(0) = urad(0) + radlu - clrurad(0) = clrurad(0) + radclru - - do lev = 1, nlayers -! Cloudy layer - if (icldlyr(lev) .eq. 1) then - gassrc = bbugas(lev) * atrans(lev) - radlu = radlu - radlu * (atrans(lev) + & - & efclfrac(lev,igc) * (1._rb - atrans(lev))) + & - & gassrc + cldfmc(igc,lev) * & - & (bbutot(lev) * atot(lev) - gassrc) - urad(lev) = urad(lev) + radlu -! Clear layer - else - radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) - urad(lev) = urad(lev) + radlu - endif -! Set clear sky stream to total sky stream as long as all layers -! are clear (iclddn=0). Streams must be calculated separately at -! all layers when a cloud is present (ICLDDN=1), because surface -! reflectance is different for each stream. - if (iclddn.eq.1) then - radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) - clrurad(lev) = clrurad(lev) + radclru - else - radclru = radlu - clrurad(lev) = urad(lev) - endif - enddo - -! Increment g-point counter - igc = igc + 1 -! Return to continue radiative transfer for all g-channels in present band - if (igc .le. ngs(iband)) go to 1000 - -! Process longwave output from band for total and clear streams. -! Calculate upward, downward, and net flux. - do lev = nlayers, 0, -1 - uflux(lev) = urad(lev)*wtdiff - dflux(lev) = drad(lev)*wtdiff - urad(lev) = 0.0_rb - drad(lev) = 0.0_rb - totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband) - totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband) - uclfl(lev) = clrurad(lev)*wtdiff - dclfl(lev) = clrdrad(lev)*wtdiff - clrurad(lev) = 0.0_rb - clrdrad(lev) = 0.0_rb - totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband) - totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband) - enddo - -! End spectral band loop - enddo - -! Calculate fluxes at surface - totuflux(0) = totuflux(0) * fluxfac - totdflux(0) = totdflux(0) * fluxfac - fnet(0) = totuflux(0) - totdflux(0) - totuclfl(0) = totuclfl(0) * fluxfac - totdclfl(0) = totdclfl(0) * fluxfac - fnetc(0) = totuclfl(0) - totdclfl(0) - -! Calculate fluxes at model levels - do lev = 1, nlayers - totuflux(lev) = totuflux(lev) * fluxfac - totdflux(lev) = totdflux(lev) * fluxfac - fnet(lev) = totuflux(lev) - totdflux(lev) - totuclfl(lev) = totuclfl(lev) * fluxfac - totdclfl(lev) = totdclfl(lev) * fluxfac - fnetc(lev) = totuclfl(lev) - totdclfl(lev) - l = lev - 1 - -! Calculate heating rates at model layers - htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev)) - htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev)) - enddo - -! Set heating rate to zero in top layer - htr(nlayers) = 0.0_rb - htrc(nlayers) = 0.0_rb - - end subroutine rtrnmc_mcica ! ------------------------------------------------------------------------------ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & @@ -8968,4 +7794,4 @@ end subroutine cldprmc !........................................!$ end module rrtmg_lw !$ -!========================================!$ \ No newline at end of file +!========================================!$ diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index 70d820922..df1a368c5 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f,HWRF_mcica_random_numbers.F90,HWRF_mersenne_twister.F90 + dependencies = mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] @@ -352,9 +352,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 0f5a8b110..d09f586a3 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -404,9 +404,7 @@ module rrtmg_sw ! --- public accessable subprograms - public rrtmg_sw_init, rrtmg_sw_run, rrtmg_sw_finalize, rswinit, & - & kissvec, generate_stochastic_clouds_sw, mcica_subcol_sw - + public rrtmg_sw_init, rrtmg_sw_run, rrtmg_sw_finalize, rswinit ! ================= contains @@ -758,74 +756,6 @@ subroutine rrtmg_sw_run & & intent(inout) :: fdncmp ! --- locals: -!mz* HWRF -- input of mcica_subcol_sw - real(kind=kind_phys),dimension(npts,nlay) :: hgt - real(kind=kind_phys) :: dzsum - real(kind=kind_phys),dimension( nbdsw, npts, nlay ) :: taucld3, & - ssacld3, & - asmcld3, & - fsfcld3 - -!mz* HWRF -- OUTPUT from mcica_subcol_sw - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: cldfmcl ! Cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: ciwpmcl ! In-cloud ice water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: clwpmcl ! In-cloud liquid water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: cswpmcl ! In-cloud snow water path (g/m2) - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=kind_phys),dimension(npts,nlay) :: relqmcl ! Cloud water drop effective radius (microns) - ! Dimensions: (ncol,nlay) - real(kind=kind_phys),dimension(npts,nlay) :: reicmcl ! Cloud ice effective size (microns) - ! Dimensions: (ncol,nlay) - real(kind=kind_phys),dimension(npts,nlay) :: resnmcl ! Snow effective size (microns) - ! Dimensions: (ncol,nlay) - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: taucmcl ! In-cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: ssacmcl ! in-cloud single scattering albedo [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: asmcmcl ! in-cloud asymmetry parameter [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=kind_phys),dimension(ngptsw,npts,nlay) :: fsfcmcl ! in-cloud forward scattering fraction [mcica] - ! Dimensions: (ngptsw,ncol,nlay) -!HWRF cldprmc_sw input -! real(kind=kind_phys),dimension(ngptsw,nlay) :: cldfmc,cldfmc_save! cloud fraction [mcica] -! ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: ciwpmc ! cloud ice water path [mcica] - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: clwpmc ! cloud liquid water path [mcica] - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: cswpmc ! cloud snow water path [mcica] - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(nlay) :: resnmc ! cloud snow particle effective radius (microns) - ! Dimensions: (nlayers) - real(kind=kind_phys),dimension(nlay) :: relqmc ! cloud liquid particle effective radius (microns) - ! Dimensions: (nlayers) - real(kind=kind_phys),dimension(nlay) :: reicmc ! cloud ice particle effective radius (microns) - ! Dimensions: (nlayers) - ! specific definition of reicmc depends on setting of iceflag: - ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), - ! r_ec range is limited to 13.0 to 130.0 microns - ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) - ! r_k range is limited to 5.0 to 131.0 microns - ! iceflag = 3: generalized effective size, dge, (Fu, 1996), - ! dge range is limited to 5.0 to 140.0 microns - ! [dge = 1.0315 * r_ec] - real(kind=kind_phys),dimension(ngptsw,nlay) :: fsfcmc ! cloud forward scattering fraction - ! Dimensions: (ngptsw,nlayers) - -!mz* HWRF cldprmc_sw output (delta scaled) - real(kind=kind_phys),dimension(ngptsw,nlay) :: taucmc ! cloud optical depth (delta scaled) - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: ssacmc ! single scattering albedo (delta scaled) - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: asmcmc ! asymmetry parameter (delta scaled) - ! Dimensions: (ngptsw,nlayers) - real(kind=kind_phys),dimension(ngptsw,nlay) :: taormc ! cloud optical depth (non-delta scaled) - ! Dimensions: (ngptsw,nlayers) -!mz* - real (kind=kind_phys), dimension(nlay,ngptsw) :: cldfmc, & & cldfmc_save, & & taug, taur @@ -980,52 +910,6 @@ subroutine rrtmg_sw_run & albbm(2) = sfcalb_uvis_dir(j1) albdf(2) = sfcalb_uvis_dif(j1) - -! mz*: HWRF - if (iovr == 4 ) then - - -!Add layer height needed for exponential (icld=4) and -! exponential-random (icld=5) overlap options - - !iplon = 1 - irng = 0 - permuteseed = 1 - -!mz* Derive height of each layer mid-point from layer thickness. -! Needed for exponential (iovr=4) and exponential-random overlap -! option (iovr=5)only. - dzsum =0.0 - do k = 1,nlay - hgt(j1,k)= dzsum+0.5*dzlyr(j1,k)*1000. !km->m - dzsum = dzsum+ dzlyr(j1,k)*1000. - enddo - -! Zero out cloud optical properties here; not used when passing physical properties -! to radiation and taucld is calculated in radiation - do k = 1, nlay - do ib = 1, nbdsw - taucld3(ib,j1,k) = 0.0 - ssacld3(ib,j1,k) = 1.0 - asmcld3(ib,j1,k) = 0.0 - fsfcld3(ib,j1,k) = 0.0 - enddo - enddo - - call mcica_subcol_sw (1, 1, nlay, iovr, permuteseed, & - & irng, plyr(j1:j1,:), hgt(j1:j1,:), & - & cld_cf(j1:j1,:), cld_iwp(j1:j1,:), cld_lwp(j1:j1,:), & - & cld_swp(j1:j1,:), cld_ref_ice(j1:j1,:), cld_ref_liq(j1:j1,:), & - & cld_ref_snow(j1:j1,:), taucld3(:,j1:j1,:), ssacld3(:,j1:j1,:), & - & asmcld3(:,j1:j1,:), fsfcld3(:,j1:j1,:), cldfmcl(:,j1:j1,:), & !--output - & ciwpmcl(:,j1:j1,:), clwpmcl(:,j1:j1,:), cswpmcl(:,j1:j1,:), & - & reicmcl(j1:j1,:), relqmcl(j1:j1,:), resnmcl(j1:j1,:), & - & taucmcl(:,j1:j1,:), ssacmcl(:,j1:j1,:), asmcmcl(:,j1:j1,:), & - & fsfcmcl(:,j1:j1,:)) - - endif -!mz* end - !> -# Prepare atmospheric profile for use in rrtm. ! the vertical index of internal array is from surface to top @@ -1111,28 +995,6 @@ subroutine rrtmg_sw_run & cdat3(k) = cld_swp(j1,kk) ! cloud snow path cdat4(k) = cld_ref_snow(j1,kk) ! snow partical effctive radius enddo - if (iovr == 4) then !mz* HWRF - do k = 1, nlay - kk = nlp1 - k - do ig = 1, ngptsw - cldfmc(k,ig) = cldfmcl(ig,j1,kk) - taucmc(ig,k) = taucmcl(ig,j1,kk) - ssacmc(ig,k) = ssacmcl(ig,j1,kk) - asmcmc(ig,k) = asmcmcl(ig,j1,kk) - fsfcmc(ig,k) = fsfcmcl(ig,j1,kk) - ciwpmc(ig,k) = ciwpmcl(ig,j1,kk) - clwpmc(ig,k) = clwpmcl(ig,j1,kk) - if (iceflgsw.eq.5) then - cswpmc(ig,k) = cswpmcl(ig,j1,kk) - endif - enddo - reicmc(k) = reicmcl(j1,kk) - relqmc(k) = relqmcl(j1,kk) - if (iceflgsw.eq.5) then - resnmc(k) = resnmcl(j1,kk) - endif - enddo - endif else ! use diagnostic cloud method do k = 1, nlay kk = nlp1 - k @@ -1226,31 +1088,6 @@ subroutine rrtmg_sw_run & cdat3(k) = cld_swp(j1,k) ! cloud snow path cdat4(k) = cld_ref_snow(j1,k) ! snow partical effctive radius enddo - if (iovr == 4) then !mz* HWRF -!mz* Move incoming GCM cloud arrays to RRTMG cloud arrays. -!For GCM input, incoming reicmcl is defined based on selected -!ice parameterization (inflglw) - do k = 1, nlay - do ig = 1, ngptsw - cldfmc(k,ig) = cldfmcl(ig,j1,k) - taucmc(ig,k) = taucmcl(ig,j1,k) - ssacmc(ig,k) = ssacmcl(ig,j1,k) - asmcmc(ig,k) = asmcmcl(ig,j1,k) - fsfcmc(ig,k) = fsfcmcl(ig,j1,k) - ciwpmc(ig,k) = ciwpmcl(ig,j1,k) - clwpmc(ig,k) = clwpmcl(ig,j1,k) - if (iceflgsw .eq. 5) then - cswpmc(ig,k) = cswpmcl(ig,j1,k) - endif - enddo - reicmc(k) = reicmcl(j1,k) - relqmc(k) = relqmcl(j1,k) - if (iceflgsw .eq. 5) then - resnmc(k) = resnmcl(j1,k) - endif - enddo - - end if else ! use diagnostic cloud method do k = 1, nlay cfrac(k) = cld_cf(j1,k) ! cloud fraction @@ -1273,7 +1110,7 @@ subroutine rrtmg_sw_run & do k = 1, nlay zcf0 = zcf0 * (f_one - cfrac(k)) enddo - else if (iovr == 1 .or. iovr == 4) then ! max/ran/exp overlapping + else if (iovr == 1) then ! max/ran/exp overlapping do k = 1, nlay if (cfrac(k) > ftiny) then ! cloudy layer zcf1 = min ( zcf1, f_one-cfrac(k) ) @@ -1283,7 +1120,7 @@ subroutine rrtmg_sw_run & endif enddo zcf0 = zcf0 * zcf1 - else if (iovr >= 2 .and. iovr /= 4) then + else if (iovr >= 2) then do k = 1, nlay zcf0 = min ( zcf0, f_one-cfrac(k) ) ! used only as clear/cloudy indicator enddo @@ -1298,15 +1135,6 @@ subroutine rrtmg_sw_run & if (zcf1 > f_zero) then ! cloudy sky column - !mz* for HWRF, save cldfmc with mcica - if (iovr == 4) then - do k = 1, nlay - do ig = 1, ngptsw - cldfmc_save(k,ig)=cldfmc (k,ig) - enddo - enddo - endif - call cldprop & ! --- inputs: & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & @@ -1315,15 +1143,6 @@ subroutine rrtmg_sw_run & & taucw, ssacw, asycw, cldfrc, cldfmc & & ) - if (iovr == 4) then - !mz for HWRF, still using mcica cldfmc - do k = 1, nlay - do ig = 1, ngptsw - cldfmc(k,ig)=cldfmc_save(k,ig) - enddo - enddo - endif - ! --- ... save computed layer cloud optical depth for output ! rrtm band 10 is approx to the 0.55 mu spectrum @@ -1617,6 +1436,8 @@ subroutine rswinit & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud ! ! =3: decorrelation-length overlap clouds ! +! =4: exponential cloud overlap (AER) ! +! =5: exponential-random cloud overlap (AER) ! ! iswmode - control flag for 2-stream transfer scheme ! ! =1; delta-eddington (joseph et al., 1976) ! ! =2: pifm (zdunkowski et al., 1980) ! @@ -1648,7 +1469,7 @@ subroutine rswinit & ! !===> ... begin here ! - if ( iovr<0 .or. iovr>4 ) then + if ( iovr<0 .or. iovr>5 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVR=',iovr,' in RSWINIT !!' stop @@ -2116,7 +1937,7 @@ subroutine cldprop & !> -# if physparam::isubcsw > 0, call mcica_subcol() to distribute !! cloud properties to each g-point. - if ( isubcsw > 0 .and. iovr /= 4 ) then ! mcica sub-col clouds approx + if ( isubcsw > 0 ) then ! mcica sub-col clouds approx cldf(:) = cfrac(:) where (cldf(:) < ftiny) @@ -5804,578 +5625,6 @@ end subroutine taumol29 end subroutine taumol !----------------------------------- -!mz* HWRF subroutines - subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, & - & irng, play, hgt, & - & cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, & - & ssac, asmc, fsfc, & - & cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, & - & relqmcl, resnmcl, & - & taucmcl, ssacmcl, asmcmcl, fsfcmcl) - -! ----- Input ----- -! Control - integer(kind=im), intent(in) :: iplon ! column/longitude dimension - integer(kind=im), intent(in) :: ncol ! number of columns - integer(kind=im), intent(in) :: nlay ! number of model layers - integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(in) :: permuteseed ! if the cloud generator is called multiple times, - ! permute the seed between each call; - ! between calls for LW and SW, recommended - ! permuteseed differs by 'ngpt' - integer(kind=im), intent(inout) :: irng ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne Twister - -! Atmosphere - real(kind=rb), intent(in) :: play(:,:) ! layer pressures (mb) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) - ! Dimensions: (ncol,nlay) - -! Atmosphere/clouds - cldprop - real(kind=rb), intent(in) :: cldfrac(:,:) ! layer cloud fraction - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: rei(:,:) ! cloud ice particle size - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: rel(:,:) ! cloud liquid particle size - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: res(:,:) ! cloud snow particle size - ! Dimensions: (ncol,nlay) - -! ----- Output ----- -! Atmosphere/clouds - cldprmc [mcica] - real(kind=rb), intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: relqmcl(:,:) ! liquid particle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: reicmcl(:,:) ! ice partcle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: resnmcl(:,:) ! snow partcle size (microns) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: ssacmcl(:,:,:) ! in-cloud single scattering albedo [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: asmcmcl(:,:,:) ! in-cloud asymmetry parameter [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: fsfcmcl(:,:,:) ! in-cloud forward scattering fraction [mcica] - ! Dimensions: (ngptsw,ncol,nlay) - -! ----- Local ----- - -! Stochastic cloud generator variables [mcica] - integer(kind=im), parameter :: nsubcsw = ngptsw ! number of sub-columns (g-point intervals) - integer(kind=im) :: ilev ! loop index - - real(kind=rb) :: pmid(ncol,nlay) ! layer pressures (Pa) -! real(kind=rb) :: pdel(ncol,nlay) ! layer pressure thickness (Pa) -! real(kind=rb) :: qi(ncol,nlay) ! ice water (specific humidity) -! real(kind=rb) :: ql(ncol,nlay) ! liq water (specific humidity) - -! Return if clear sky - if (icld.eq.0) return - -! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns - -! Pass particle sizes to new arrays, no subcolumns for these properties yet -! Convert pressures from mb to Pa - - reicmcl(:ncol,:nlay) = rei(:ncol,:nlay) - relqmcl(:ncol,:nlay) = rel(:ncol,:nlay) - resnmcl(:ncol,:nlay) = res(:ncol,:nlay) - pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb - -! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components - -! cwp = (q * pdel * 1000.) / gravit) -! = (kg/kg * kg m-1 s-2 *1000.) / m s-2 -! = (g m-2) -! -! q = (cwp * gravit) / (pdel *1000.) -! = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.) -! = kg/kg - -! do ilev = 1, nlay -! qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb) -! ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb) -! enddo - - call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, & - & irng, pmid, hgt, cldfrac, clwp, ciwp, cswp, & - & tauc, ssac, asmc, fsfc, cldfmcl, clwpmcl, & - & ciwpmcl, cswpmcl, & - & taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed) - - end subroutine mcica_subcol_sw - -!------------------------------------------------------------------------------------------------- - subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, & - & icld, irng, pmid, hgt, cld, clwp, ciwp, cswp, & - & tauc, ssac, asmc, fsfc, cld_stoch, clwp_stoch, & - & ciwp_stoch, cswp_stoch, & - & tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed) -!------------------------------------------------------------------------------------------------- -! Contact: Cecile Hannay (hannay@ucar.edu) -! -! Original code: Based on Raisanen et al., QJRMS, 2004. -! -! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default -! random number generator, which can be changed to the optional kissvec random number generator -! with flag 'irng'. Some extra functionality has been commented or removed. -! Michael J. Iacono, AER, Inc., February 2007 -! -! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. -! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one -! and uniform cloud liquid and cloud ice concentration. -! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer -! and obeys an overlap assumption in the vertical. -! -! Overlap assumption: -! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. -! The default option is maximum-random (option 3) -! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap -! This is set with the variable "overlap" -!mji - Exponential overlap option (overlap=4) has been deactivated in this version -! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) -! -! Seed: -! If the stochastic cloud generator is called several times during the same timestep, -! one should change the seed between the call to insure that the subcolumns are different. -! This is done by changing the argument 'changeSeed' -! For example, if one wants to create a set of columns for the shortwave and another set for the longwave , -! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call -! -! PDF assumption: -! We can use arbitrary complicated PDFS. -! In the present version, we produce homogeneuous clouds (the simplest case). -! Future developments include using the PDF scheme of Ben Johnson. -! -! History file: -! Option to add diagnostics variables in the history file. (using FINCL in the namelist) -! nsubcol = number of subcolumns -! overlap = overlap type (1-3) -! Zo = length scale -! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) -! CLDLIQ_S = mean of the subcolumn cloud water -! CLDICE_S = mean of the subcolumn cloud ice -! -! -! Note: -! Here: we force that the cloud condensate to be consistent with the cloud fraction -! i.e we only have cloud condensate when the cell is cloudy. -! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations -! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction -! without cloud condensate or the opposite). -!---------------------------------------------------------------------- - - use mcica_random_numbers -! The Mersenne Twister random number engine - use MersenneTwister, only: randomNumberSequence, & - new_RandomNumberSequence, getRandomReal - - type(randomNumberSequence) :: randomNumbers - -! -- Arguments - - integer(kind=im), intent(in) :: ncol ! number of layers - integer(kind=im), intent(in) :: nlay ! number of layers - integer(kind=im), intent(in) :: icld ! clear/cloud, cloud overlap flag - integer(kind=im), intent(inout) :: irng ! flag for random number generator - ! 0 = kissvec - ! 1 = Mersenne Twister - integer(kind=im), intent(in) :: nsubcol ! number of sub-columns (g-point intervals) - integer(kind=im), optional, intent(in) :: changeSeed ! allows permuting seed - -! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state - real(kind=rb), intent(in) :: pmid(:,:) ! layer pressure (Pa) - ! Dimensions: (ncol,nlay) -! mji - Add height - real(kind=rb), intent(in) :: hgt(:,:) ! layer height (m) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cld(:,:) ! cloud fraction - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2) - ! Dimensions: (ncol,nlay) - real(kind=rb), intent(in) :: tauc(:,:,:) ! in-cloud optical depth (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) - ! Dimensions: (nbndsw,ncol,nlay) - real(kind=rb), intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter - ! Dimensions: (ngptsw,ncol,nlay) - real(kind=rb), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction - ! Dimensions: (ngptsw,ncol,nlay) - -! -- Local variables - real(kind=rb) :: cldf(ncol,nlay) ! cloud fraction - ! Dimensions: (ncol,nlay) - -! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive -! real(kind=rb) :: mean_cld_stoch(ncol,nlay) ! cloud fraction -! real(kind=rb) :: mean_clwp_stoch(ncol,nlay) ! cloud water -! real(kind=rb) :: mean_ciwp_stoch(ncol,nlay) ! cloud ice -! real(kind=rb) :: mean_tauc_stoch(ncol,nlay) ! cloud optical depth -! real(kind=rb) :: mean_ssac_stoch(ncol,nlay) ! cloud single scattering albedo -! real(kind=rb) :: mean_asmc_stoch(ncol,nlay) ! cloud asymmetry parameter -! real(kind=rb) :: mean_fsfc_stoch(ncol,nlay) ! cloud forward scattering fraction - -! Set overlap - integer(kind=im) :: overlap ! 1 = random overlap, 2 = maximum-random, - ! 3 = maximum overlap, 4 = exponential, - ! 5 = exponential-random - real(kind=rb), parameter :: Zo = 2500._rb ! length scale (m) - real(kind=rb), dimension(ncol,nlay) :: alpha ! overlap parameter - -! Constants (min value for cloud fraction and cloud water and ice) - real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction -! real(kind=rb), parameter :: qmin = 1.0e-10_rb ! min cloud water and cloud ice (not used) - -! Variables related to random number and seed - real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2 ! random numbers - integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number - real(kind=rb), dimension(ncol) :: rand_num ! random number (kissvec) - integer(kind=im) :: iseed ! seed to create random number (Mersenne Twister) - real(kind=rb) :: rand_num_mt ! random number (Mersenne Twister) - -! Flag to identify cloud fraction in subcolumns - logical, dimension(nsubcol, ncol, nlay) :: isCloudy ! flag that says whether a gridbox is cloudy - -! Indices - integer(kind=im) :: ilev, isubcol, i, n, ngbm ! indices - -!------------------------------------------------------------------------------------------ - -! Check that irng is in bounds; if not, set to default - if (irng .ne. 0) irng = 1 - -! Pass input cloud overlap setting to local variable - overlap = icld - -! Ensure that cloud fractions are in bounds - do ilev = 1, nlay - do i = 1, ncol - cldf(i,ilev) = cld(i,ilev) - if (cldf(i,ilev) < cldmin) then - cldf(i,ilev) = 0._rb - endif - enddo - enddo - -! ----- Create seed -------- - -! Advance randum number generator by changeseed values - if (irng.eq.0) then -! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. - -! Must use pmid from bottom four layers. - do i=1,ncol - if (pmid(i,1).lt.pmid(i,2)) then - stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.' - endif - seed1(i) = (pmid(i,1) - int(pmid(i,1))) * 1000000000_im - seed2(i) = (pmid(i,2) - int(pmid(i,2))) * 1000000000_im - seed3(i) = (pmid(i,3) - int(pmid(i,3))) * 1000000000_im - seed4(i) = (pmid(i,4) - int(pmid(i,4))) * 1000000000_im - enddo - do i=1,changeSeed - call kissvec(seed1, seed2, seed3, seed4, rand_num) - enddo - elseif (irng.eq.1) then - randomNumbers = new_RandomNumberSequence(seed = changeSeed) - endif - - -! ------ Apply overlap assumption -------- - -! generate the random numbers - - select case (overlap) - - - case(1) -! Random overlap -! i) pick a random value at every level - - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - case(2) -! Maximum-Random overlap -! i) pick a random number for top layer. -! ii) walk down the column: -! - if the layer above is cloudy, we use the same random number than in the layer above -! - if the layer above is clear, we use a new random number - - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - do ilev = 2,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) - else - CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1)) - endif - enddo - enddo - enddo - - - case(3) -! Maximum overlap -! i) pick same random numebr at every level - - if (irng.eq.0) then - do isubcol = 1,nsubcol - call kissvec(seed1, seed2, seed3, seed4, rand_num) - do ilev = 1,nlay - CDF(isubcol,:,ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - rand_num_mt = getRandomReal(randomNumbers) - do ilev = 1, nlay - CDF(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - -! mji - Activate exponential cloud overlap option - case(4) - ! Exponential overlap: weighting between maximum and random overlap increases with the distance. - ! The random numbers for exponential overlap verify: - ! j=1 RAN(j)=RND1 - ! j>1 if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1) - ! RAN(j) = RND2 - ! alpha is obtained from the equation - ! alpha = exp(-(Z(j)-Z(j-1))/Zo) where Zo is a characteristic length scale - - ! compute alpha - do i = 1, ncol - alpha(i, 1) = 0._rb - do ilev = 2,nlay - alpha(i, ilev) = exp( -( hgt (i, ilev) - hgt (i, ilev-1)) / Zo) - enddo - enddo - - ! generate 2 streams of random numbers - if (irng.eq.0) then - do isubcol = 1,nsubcol - do ilev = 1,nlay - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF(isubcol, :, ilev) = rand_num - call kissvec(seed1, seed2, seed3, seed4, rand_num) - CDF2(isubcol, :, ilev) = rand_num - enddo - enddo - elseif (irng.eq.1) then - do isubcol = 1, nsubcol - do i = 1, ncol - do ilev = 1, nlay - rand_num_mt = getRandomReal(randomNumbers) - CDF(isubcol,i,ilev) = rand_num_mt - rand_num_mt = getRandomReal(randomNumbers) - CDF2(isubcol,i,ilev) = rand_num_mt - enddo - enddo - enddo - endif - - ! generate random numbers - do ilev = 2,nlay - where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) ) - CDF(:,:,ilev) = CDF(:,:,ilev-1) - end where - end do - -! mji - Activate exponential-random cloud overlap option - case(5) - ! Exponential-random overlap: -! call wrf_error_fatal("Cloud Overlap case 5: ER has not yet been implemented. Stopping...") - - end select - - -! -- generate subcolumns for homogeneous clouds ----- - do ilev = 1, nlay - isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) ) - enddo - -! where the subcolumn is cloudy, the subcolumn cloud fraction is 1; -! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0; -! where there is a cloud, define the subcolumn cloud properties, -! otherwise set these to zero - - ngbm = ngb(1) - 1 - do ilev = 1,nlay - do i = 1, ncol - do isubcol = 1, nsubcol - if ( iscloudy(isubcol,i,ilev) ) then - cld_stoch(isubcol,i,ilev) = 1._rb - clwp_stoch(isubcol,i,ilev) = clwp(i,ilev) - ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev) - cswp_stoch(isubcol,i,ilev) = cswp(i,ilev) - n = ngb(isubcol) - ngbm - tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev) - ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev) - asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev) - fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev) - else - cld_stoch(isubcol,i,ilev) = 0._rb - clwp_stoch(isubcol,i,ilev) = 0._rb - ciwp_stoch(isubcol,i,ilev) = 0._rb - cswp_stoch(isubcol,i,ilev) = 0._rb - tauc_stoch(isubcol,i,ilev) = 0._rb - ssac_stoch(isubcol,i,ilev) = 1._rb - asmc_stoch(isubcol,i,ilev) = 0._rb - fsfc_stoch(isubcol,i,ilev) = 0._rb - endif - enddo - enddo - enddo - - -! -- compute the means of the subcolumns --- -! mean_cld_stoch(:,:) = 0._rb -! mean_clwp_stoch(:,:) = 0._rb -! mean_ciwp_stoch(:,:) = 0._rb -! mean_tauc_stoch(:,:) = 0._rb -! mean_ssac_stoch(:,:) = 0._rb -! mean_asmc_stoch(:,:) = 0._rb -! mean_fsfc_stoch(:,:) = 0._rb -! do i = 1, nsubcol -! mean_cld_stoch(:,:) = cld_stoch(i,:,:) + mean_cld_stoch(:,:) -! mean_clwp_stoch(:,:) = clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) -! mean_ciwp_stoch(:,:) = ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) -! mean_tauc_stoch(:,:) = tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) -! mean_ssac_stoch(:,:) = ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) -! mean_asmc_stoch(:,:) = asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) -! mean_fsfc_stoch(:,:) = fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:) -! end do -! mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol -! mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol -! mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol -! mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol -! mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol -! mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol -! mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol - - end subroutine generate_stochastic_clouds_sw - - -!-------------------------------------------------------------------------------------------------- - subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) -!-------------------------------------------------------------------------------------------------- - -! public domain code made available from http://www.fortran.com/ -! downloaded by pjr on 03/16/04 for NCAR CAM -! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 - -! The KISS (Keep It Simple Stupid) random number generator. Combines: -! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. -! (2) A 3-shift shift-register generator, period 2^32-1, -! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 -! Overall period>2^123; - -! - real(kind=rb), dimension(:), intent(inout) :: ran_arr - integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4 - integer(kind=im) :: i,sz,kiss - integer(kind=im) :: m, k, n - -! inline function - m(k, n) = ieor (k, ishft (k, n) ) - - sz = size(ran_arr) - do i = 1, sz - seed1(i) = 69069_im * seed1(i) + 1327217885_im - seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im) - seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im) - seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im) - kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i) - ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb - end do - - end subroutine kissvec - -!! @} - -! !........................................! end module rrtmg_sw ! !========================================! diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 187d26f21..70bc136f3 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f,HWRF_mcica_random_numbers.F90,HWRF_mersenne_twister.F90 + dependencies = mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] @@ -413,9 +413,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rascnv.meta b/physics/rascnv.meta index f4563ea89..9ace89287 100644 --- a/physics/rascnv.meta +++ b/physics/rascnv.meta @@ -143,9 +143,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -163,9 +163,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -615,9 +615,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rayleigh_damp.meta b/physics/rayleigh_damp.meta index 568cb9486..63025bcff 100644 --- a/physics/rayleigh_damp.meta +++ b/physics/rayleigh_damp.meta @@ -183,9 +183,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmg_lw_post.meta b/physics/rrtmg_lw_post.meta index e2731faab..fc52ff901 100644 --- a/physics/rrtmg_lw_post.meta +++ b/physics/rrtmg_lw_post.meta @@ -128,9 +128,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmg_lw_pre.meta b/physics/rrtmg_lw_pre.meta index affc45384..9f6ec07c8 100644 --- a/physics/rrtmg_lw_pre.meta +++ b/physics/rrtmg_lw_pre.meta @@ -16,9 +16,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmg_sw_post.meta b/physics/rrtmg_sw_post.meta index 819090937..fb9c6dbf2 100644 --- a/physics/rrtmg_sw_post.meta +++ b/physics/rrtmg_sw_post.meta @@ -244,9 +244,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmg_sw_pre.meta b/physics/rrtmg_sw_pre.meta index f980c6a3d..6a3a4e0a4 100644 --- a/physics/rrtmg_sw_pre.meta +++ b/physics/rrtmg_sw_pre.meta @@ -52,9 +52,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta index 875143df1..165051409 100644 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ b/physics/rrtmgp_lw_aerosol_optics.meta @@ -145,9 +145,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index 4617912cc..35e27979e 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -81,9 +81,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -297,9 +297,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index 2571e7295..2e4029ae2 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -167,9 +167,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index 2024df664..0b484b6ac 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -93,9 +93,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -195,9 +195,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta index 8a8b15467..aa2a06a0f 100644 --- a/physics/rrtmgp_lw_pre.meta +++ b/physics/rrtmgp_lw_pre.meta @@ -39,9 +39,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index 752251c43..069537964 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -165,9 +165,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/rrtmgp_sw_aerosol_optics.meta index f56a54467..2abacd92a 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/rrtmgp_sw_aerosol_optics.meta @@ -160,9 +160,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index 4856d44d5..d73258cb2 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -81,9 +81,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -279,9 +279,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index 23f8fa031..cda161e81 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -174,9 +174,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta index 5bcfe6cb2..1fdbc946b 100644 --- a/physics/rrtmgp_sw_gas_optics.meta +++ b/physics/rrtmgp_sw_gas_optics.meta @@ -61,9 +61,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -186,9 +186,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index 995a5626a..e59698c0f 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -197,9 +197,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 2f34041c2..3801e684f 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -2975,11 +2975,12 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & tsump(i) = 0. rtnp(i) = 1. enddo - do k = 1,km + do k = 1,km1 do i = 1,im if(cnvflg(i) .and. k <= ktcon(i)) then - if(q1(i,k) < 0.) tsumn(i) = tsumn(i) + q1(i,k) - if(q1(i,k) > 0.) tsump(i) = tsump(i) + q1(i,k) + tem = q1(i,k) * delp(i,k) / grav + if(q1(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(q1(i,k) > 0.) tsump(i) = tsump(i) + tem endif enddo enddo @@ -2994,7 +2995,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif endif enddo - do k = 1,km + do k = 1,km1 do i = 1,im if(cnvflg(i) .and. k <= ktcon(i)) then if(rtnp(i) < 0.) then @@ -3011,6 +3012,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & enddo ! if (.not.hwrf_samfdeep) then + indx = ntk - 2 do n = 1, ntr ! do k = 1, km @@ -3033,11 +3035,21 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & tsump(i) = 0. rtnp(i) = 1. enddo - do k = 1,km + do k = 1,km1 do i = 1,im if(cnvflg(i) .and. k <= ktcon(i)) then - if(ctr(i,k,n) < 0.) tsumn(i) = tsumn(i) + ctr(i,k,n) - if(ctr(i,k,n) > 0.) tsump(i) = tsump(i) + ctr(i,k,n) + if(n == indx) then + if(k > 1) then + dz = zi(i,k) - zi(i,k-1) + else + dz = zi(i,k) + endif + tem = ctr(i,k,n) * dz + else + tem = ctr(i,k,n) * delp(i,k) / grav + endif + if(ctr(i,k,n) < 0.) tsumn(i) = tsumn(i) + tem + if(ctr(i,k,n) > 0.) tsump(i) = tsump(i) + tem endif enddo enddo @@ -3052,7 +3064,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif endif enddo - do k = 1,km + do k = 1,km1 do i = 1,im if(cnvflg(i) .and. k <= ktcon(i)) then if(rtnp(i) < 0.) then diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index d38203465..baf01fb8e 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -30,9 +30,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -600,9 +600,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 846fb30c1..0e11ed49c 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -1922,12 +1922,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & tsump(i) = 0. rtnp(i) = 1. enddo - do k = 1,km + do k = 1,km1 do i = 1,im if (cnvflg(i)) then if(k > kb(i) .and. k <= ktcon(i)) then - if(q1(i,k) < 0.) tsumn(i) = tsumn(i) + q1(i,k) - if(q1(i,k) > 0.) tsump(i) = tsump(i) + q1(i,k) + tem = q1(i,k) * delp(i,k) / grav + if(q1(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(q1(i,k) > 0.) tsump(i) = tsump(i) + tem endif endif enddo @@ -1943,7 +1944,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif endif enddo - do k = 1,km + do k = 1,km1 do i = 1,im if (cnvflg(i)) then if(k > kb(i) .and. k <= ktcon(i)) then @@ -1963,6 +1964,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! if (.not.hwrf_samfshal) then ! + indx = ntk - 2 do n = 1, ntr ! do k = 1, km @@ -1985,12 +1987,22 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & tsump(i) = 0. rtnp(i) = 1. enddo - do k = 1,km + do k = 1,km1 do i = 1,im if (cnvflg(i)) then if(k > kb(i) .and. k <= ktcon(i)) then - if(ctr(i,k,n) < 0.) tsumn(i) = tsumn(i) + ctr(i,k,n) - if(ctr(i,k,n) > 0.) tsump(i) = tsump(i) + ctr(i,k,n) + if(n == indx) then + if(k > 1) then + dz = zi(i,k) - zi(i,k-1) + else + dz = zi(i,k) + endif + tem = ctr(i,k,n) * dz + else + tem = ctr(i,k,n) * delp(i,k) / grav + endif + if(ctr(i,k,n) < 0.) tsumn(i) = tsumn(i) + tem + if(ctr(i,k,n) > 0.) tsump(i) = tsump(i) + tem endif endif enddo @@ -2006,7 +2018,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif endif enddo - do k = 1,km + do k = 1,km1 do i = 1,im if (cnvflg(i)) then if(k > kb(i) .and. k <= ktcon(i)) then diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index cdc61c1a3..d768d4451 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -30,9 +30,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -422,9 +422,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sascnvn.meta b/physics/sascnvn.meta index 082b87d09..66e5161ad 100644 --- a/physics/sascnvn.meta +++ b/physics/sascnvn.meta @@ -30,9 +30,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -504,9 +504,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/satmedmfvdif.meta b/physics/satmedmfvdif.meta index 9eff692d8..3609ed50f 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/satmedmfvdif.meta @@ -38,9 +38,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -576,9 +576,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 6e0c1bd80..be54675b0 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -1515,8 +1515,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & endif if((pcnvflg(i) .or. scuflg(i)) .and. & (k >= kbx .and. k <= kmx)) then - if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + f1(i,k) - if(f1(i,k) > 0.) tsump(i) = tsump(i) + f1(i,k) + dz = zi(i,k+1) - zi(i,k) + tem = f1(i,k) * dz + if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(f1(i,k) > 0.) tsump(i) = tsump(i) + tem endif enddo enddo @@ -1569,8 +1571,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & enddo do k = 1,km do i = 1,im - if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + f1(i,k) - if(f1(i,k) > 0.) tsump(i) = tsump(i) + f1(i,k) + dz = zi(i,k+1) - zi(i,k) + tem = f1(i,k) * dz + if(f1(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(f1(i,k) > 0.) tsump(i) = tsump(i) + tem enddo enddo do i = 1,im @@ -1760,8 +1764,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & endif if((pcnvflg(i) .or. scuflg(i)) .and. & (k >= kbx .and. k <= kmx)) then - if(f2(i,k) < 0.) tsumn(i) = tsumn(i) + f2(i,k) - if(f2(i,k) > 0.) tsump(i) = tsump(i) + f2(i,k) + tem = f2(i,k) * del(i,k) / grav + if(f2(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(f2(i,k) > 0.) tsump(i) = tsump(i) + tem endif enddo enddo @@ -1815,8 +1820,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & enddo do k = 1,km do i = 1,im - if(f2(i,k) < 0.) tsumn(i) = tsumn(i) + f2(i,k) - if(f2(i,k) > 0.) tsump(i) = tsump(i) + f2(i,k) + tem = f2(i,k) * del(i,k) / grav + if(f2(i,k) < 0.) tsumn(i) = tsumn(i) + tem + if(f2(i,k) > 0.) tsump(i) = tsump(i) + tem enddo enddo do i = 1,im @@ -1943,8 +1949,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & endif if((pcnvflg(i) .or. scuflg(i)) .and. & (k >= kbx .and. k <= kmx)) then - if(f2(i,k+is) < 0.) tsumn(i) = tsumn(i) + f2(i,k+is) - if(f2(i,k+is) > 0.) tsump(i) = tsump(i) + f2(i,k+is) + tem = f2(i,k+is) * del(i,k) / grav + if(f2(i,k+is) < 0.) tsumn(i) = tsumn(i) + tem + if(f2(i,k+is) > 0.) tsump(i) = tsump(i) + tem endif enddo enddo @@ -1998,8 +2005,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw,ntiw,ntke, & enddo do k = 1,km do i = 1,im - if(f2(i,k+is) < 0.) tsumn(i) = tsumn(i) + f2(i,k+is) - if(f2(i,k+is) > 0.) tsump(i) = tsump(i) + f2(i,k+is) + tem = f2(i,k+is) * del(i,k) / grav + if(f2(i,k+is) < 0.) tsumn(i) = tsumn(i) + tem + if(f2(i,k+is) > 0.) tsump(i) = tsump(i) + tem enddo enddo do i = 1,im diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index d6fb95715..db89f488d 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -37,9 +37,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -646,9 +646,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/scm_sfc_flux_spec.meta b/physics/scm_sfc_flux_spec.meta index 9ff2f15c4..46bb10897 100644 --- a/physics/scm_sfc_flux_spec.meta +++ b/physics/scm_sfc_flux_spec.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -307,9 +307,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_cice.meta b/physics/sfc_cice.meta index fd259111a..796fb2f5d 100644 --- a/physics/sfc_cice.meta +++ b/physics/sfc_cice.meta @@ -236,9 +236,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index d19a62542..dd3bf79b8 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -206,9 +206,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta index 21d76a147..873dd671e 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/sfc_diag_post.meta @@ -179,9 +179,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 84c01caaa..c745e3c1e 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -40,8 +40,8 @@ end subroutine sfc_diff_finalize !! in Zeng et al. (1998) \cite zeng_et_al_1998). !! - Calculate Zeng's momentum roughness length formulation over land and sea ice. !! - Calculate the new vegetation-dependent formulation of thermal roughness length -!! (Zheng et al.(2009) \cite zheng_et_al_2009). -!! Zheng et al. (2009) \cite zheng_et_al_2009 proposed a new formulation on +!! (Zheng et al.(2012) \cite zheng_et_al_2012). +!! Zheng et al. (2012) \cite zheng_et_al_2012 proposed a new formulation on !! \f$ln(Z_{0m}^,/Z_{0t})\f$ as follows: !! \f[ !! ln(Z_{0m}^,/Z_{0t})=(1-GVF)^2C_{zil}k(u*Z_{0g}/\nu)^{0.5} @@ -305,12 +305,14 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) tem2 = tem1 * tem1 tem1 = one - tem2 - if( ivegsrc == 1 ) then - - z0max = exp( tem2*log01 + tem1*log(z0max) ) - elseif (ivegsrc == 2 ) then - z0max = exp( tem2*log01 + tem1*log(z0max) ) - endif +! Removed the following lines by W. Zheng, for effective z0m (z0max) is applied only +! for land. +!wz if( ivegsrc == 1 ) then +!wz +!wz z0max = exp( tem2*log01 + tem1*log(z0max) ) +!wz elseif (ivegsrc == 2 ) then +!wz z0max = exp( tem2*log01 + tem1*log(z0max) ) +!wz endif z0max = max(z0max, zmin) diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 86268392d..a2e1fe9f7 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -574,9 +574,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_drv.meta b/physics/sfc_drv.meta index 6463a3ed7..a3aa9044e 100644 --- a/physics/sfc_drv.meta +++ b/physics/sfc_drv.meta @@ -74,9 +74,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -94,9 +94,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -743,9 +743,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index ecea7a670..4c42f17fe 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -31,7 +31,7 @@ module lsm_ruc !! \htmlinclude lsm_ruc_init.html !! subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & - flag_restart, flag_init, con_fvirt, con_rd, & + lsm_cold_start, flag_init, con_fvirt, con_rd, & im, lsoil_ruc, lsoil, kice, nlev, & ! in lsm_ruc, lsm, slmsk, stype, vtype, landfrac, & ! in q1, prsl1, tsfc_lnd, tsfc_ice, tsfc_wat, & ! in @@ -49,7 +49,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & implicit none ! --- in integer, intent(in) :: me, master, isot, ivegsrc, nlunit - logical, intent(in) :: flag_restart + logical, intent(in) :: lsm_cold_start logical, intent(in) :: flag_init integer, intent(in) :: im integer, intent(in) :: lsoil_ruc @@ -155,7 +155,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & write (0,*) 'tg3=',tg3(ipr) write (0,*) 'slmsk=',slmsk(ipr) write (0,*) 'flag_init =',flag_init - write (0,*) 'flag_restart =',flag_restart + write (0,*) 'lsm_cold_start =',lsm_cold_start endif !--- initialize soil vegetation @@ -169,7 +169,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & !-- initialize background emissivity semisbase(i) = lemitbl(vtype(i)) ! no snow effect - if (.not.flag_restart) then + if (lsm_cold_start) then !-- land semis_lnd(i) = semisbase(i) * (1.-sncovr_lnd(i)) & + 0.99 * sncovr_lnd(i) @@ -196,13 +196,13 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & sfcqv_lnd(i) = q0 qs1 = rslf(prsl1(i),tsfc_ice(i)) sfcqv_ice(i) = qs1 - endif ! .not. restart + endif ! lsm_cold_start enddo ! i call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in + call rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in stype, vtype, landfrac, fice, & ! in min_seaice, tsfc_lnd, tsfc_wat, tg3, & ! in @@ -210,7 +210,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) - if (.not.flag_restart) then + if (lsm_cold_start) then do i = 1, im ! i - horizontal loop do k = 1, min(kice,lsoil_ruc) ! - at initial time set sea ice T (tsice) @@ -357,7 +357,7 @@ subroutine lsm_ruc_run & ! inputs & rhosnf, sbsno, & & cmm_lnd, chh_lnd, cmm_ice, chh_ice, & ! - & flag_iter, flag_guess, flag_init, flag_restart, & + & flag_iter, flag_guess, flag_init, lsm_cold_start, & & flag_cice, frac_grid, errmsg, errflg & & ) @@ -439,7 +439,7 @@ subroutine lsm_ruc_run & ! inputs & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice - logical, intent(in) :: flag_init, flag_restart + logical, intent(in) :: flag_init, lsm_cold_start character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -589,7 +589,7 @@ subroutine lsm_ruc_run & ! inputs write (0,*)'vtype=',ipr,vtype(ipr) write (0,*)'kdt, iter =',kdt,iter write (0,*)'flag_init =',flag_init - write (0,*)'flag_restart =',flag_restart + write (0,*)'lsm_cold_start =',lsm_cold_start endif ims = 1 @@ -1098,7 +1098,7 @@ subroutine lsm_ruc_run & ! inputs !> - Call RUC LSM lsmruc() for land. call lsmruc( & - & delt, flag_init, flag_restart, kdt, iter, nsoil, & + & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_lnd(i,j), snowh_lnd(i,j), & & sncovr_lnd(i,j), & @@ -1359,7 +1359,7 @@ subroutine lsm_ruc_run & ! inputs !> - Call RUC LSM lsmruc() for ice. call lsmruc( & - & delt, flag_init, flag_restart, kdt, iter, nsoil, & + & delt, flag_init, lsm_cold_start, kdt, iter, nsoil, & & graupelncv(i,j), snowncv(i,j), rainncv(i,j), raincv(i,j), & & zs, prcp(i,j), sneqv_ice(i,j), snowh_ice(i,j), & & sncovr_ice(i,j), & @@ -1506,17 +1506,17 @@ end subroutine lsm_ruc_run !>\ingroup lsm_ruc_group !! This subroutine contains RUC LSM initialization. - subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in - me, master, lsm_ruc, lsm, slmsk, & ! in + subroutine rucinit (lsm_cold_start, im, lsoil_ruc, lsoil, & ! in + nlev, me, master, lsm_ruc, lsm, slmsk, & ! in stype, vtype, landfrac, fice, & ! in - min_seaice, tskin_lnd, tskin_wat, tg3, & ! in + min_seaice, tskin_lnd, tskin_wat, tg3, & ! in zs, dzs, smc, slc, stc, & ! in sh2o, smfrkeep, tslb, smois, & ! out wetness, errmsg, errflg) implicit none - logical, intent(in ) :: restart + logical, intent(in ) :: lsm_cold_start integer, intent(in ) :: lsm integer, intent(in ) :: lsm_ruc integer, intent(in ) :: im, nlev @@ -1599,7 +1599,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in else if (debug_print) then write (0,*) 'Start of RUC LSM initialization' write (0,*)'lsoil, lsoil_ruc =',lsoil, lsoil_ruc - write (0,*)'restart = ',restart + write (0,*)'lsm_cold_start = ',lsm_cold_start endif ipr = 10 @@ -1627,7 +1627,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in !! Check if RUC soil data (tslb, ...) is provided or not !if (minval(tslb)==maxval(tslb)) then ! For restart runs, can assume that RUC soil data is provided - if (.not.restart) then + if (lsm_cold_start) then flag_sst = 0 diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 30c05b81f..b9709c4d3 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -42,9 +42,9 @@ dimensions = () type = integer intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart +[lsm_cold_start] + standard_name = do_lsm_cold_start + long_name = flag to signify LSM is cold-started units = flag dimensions = () type = logical @@ -504,9 +504,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -524,9 +524,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1566,9 +1566,9 @@ dimensions = () type = logical intent = in -[flag_restart] - standard_name = flag_for_restart - long_name = flag for restart (warmstart) or coldstart +[lsm_cold_start] + standard_name = do_lsm_cold_start + long_name = flag to signify LSM is cold-started units = flag dimensions = () type = logical @@ -1596,9 +1596,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_noahmp_drv.F90 b/physics/sfc_noahmp_drv.F90 index 7ef542f42..1fd9773ff 100644 --- a/physics/sfc_noahmp_drv.F90 +++ b/physics/sfc_noahmp_drv.F90 @@ -118,7 +118,7 @@ subroutine noahmpdrv_run & ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & - canopy, trans, zorl, & + canopy, trans, tsurf, zorl, & rb1, fm1, fh1, ustar1, stress1, fm101, fh21, & ! --- Noah MP specific @@ -245,6 +245,7 @@ subroutine noahmpdrv_run & real(kind=kind_phys), dimension(:,:) , intent(inout) :: slc ! liquid soil moisture [m3/m3] real(kind=kind_phys), dimension(:) , intent(inout) :: canopy ! canopy moisture content [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: trans ! total plant transpiration [m/s] + real(kind=kind_phys), dimension(:) , intent(inout) :: tsurf ! surface skin temperature [K] real(kind=kind_phys), dimension(:) , intent(inout) :: zorl ! surface roughness [cm] real(kind=kind_phys), dimension(:) , intent(inout) :: rb1 ! bulk richardson # @@ -921,6 +922,7 @@ subroutine noahmpdrv_run & sncovr1 (i) = snow_cover_fraction ! qsurf (i) = spec_humidity_surface + tsurf (i) = tskin(i) tvxy (i) = temperature_leaf tgxy (i) = temperature_ground diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index c9a6c0258..ea08e6bf7 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -74,9 +74,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -662,6 +662,14 @@ type = real kind = kind_phys intent = inout +[tsurf] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [zorl] standard_name = surface_roughness_length_over_land long_name = surface roughness length over land (temporary use as interstitial) @@ -1255,9 +1263,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 7d5fcfca5..d80ebf0cf 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -611,9 +611,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -745,9 +745,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -938,9 +938,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index 85a891644..e99ad39fc 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -259,9 +259,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 312c35dfa..b88178702 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -579,10 +579,10 @@ subroutine ice3lay ! !===> ... begin here ! - dt2 = delt + delt - dt4 = dt2 + dt2 - dt6 = dt2 + dt4 - dt2i = one / dt2 + dt2 = delt + delt + dt4 = dt2 + dt2 + dt6 = dt2 + dt4 + dt2i = one / dt2 do i = 1, im if (flag(i)) then diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index c2a215a03..718109879 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -432,9 +432,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/shalcnv.meta b/physics/shalcnv.meta index 0f91a043a..f554201c5 100644 --- a/physics/shalcnv.meta +++ b/physics/shalcnv.meta @@ -44,9 +44,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -400,9 +400,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/shinhongvdif.meta b/physics/shinhongvdif.meta index 8d0dac7db..dcd3b96cd 100644 --- a/physics/shinhongvdif.meta +++ b/physics/shinhongvdif.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -488,9 +488,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/ugwpv1_gsldrag.F90 b/physics/ugwpv1_gsldrag.F90 index 71193ed88..41290ed68 100644 --- a/physics/ugwpv1_gsldrag.F90 +++ b/physics/ugwpv1_gsldrag.F90 @@ -321,7 +321,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd zogw, zlwb, zobl, zngw, dusfcg, dvsfcg, dudt, dvdt, dtdt, rdxzb, & dtend, dtidx, index_of_x_wind, index_of_y_wind, index_of_temperature, & index_of_process_orographic_gwd, index_of_process_nonorographic_gwd, & - lprnt, ipr, errmsg, errflg) + lprnt, ipr, spp_wts_gwd, spp_gwd, errmsg, errflg) + ! !######################################################################## ! Attention New Arrays and Names must be ADDED inside @@ -436,6 +437,9 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd real(kind=kind_phys), intent(out), dimension(:) :: rdxzb ! for stoch phys. mtb-level + real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) + integer, intent(in) :: spp_gwd + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -558,7 +562,8 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ntrac, lonr, dtp, fhzero,kd do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & dtend, dtidx, index_of_process_orographic_gwd, & index_of_temperature, index_of_x_wind, & - index_of_y_wind, ldiag3d, errmsg, errflg) + index_of_y_wind, ldiag3d, spp_wts_gwd, spp_gwd, & + errmsg, errflg) ! ! dusfcg = du_ogwcol + du_oblcol + du_osscol + du_ofdcol ! diff --git a/physics/ugwpv1_gsldrag.meta b/physics/ugwpv1_gsldrag.meta index ab54f458a..0e1f6ddf1 100644 --- a/physics/ugwpv1_gsldrag.meta +++ b/physics/ugwpv1_gsldrag.meta @@ -84,7 +84,7 @@ standard_name = sigma_pressure_hybrid_coordinate_a_coefficient long_name = a parameter for sigma pressure level calculations units = Pa - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -92,7 +92,7 @@ standard_name = sigma_pressure_hybrid_coordinate_b_coefficient long_name = b parameter for sigma pressure level calculations units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -248,9 +248,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -268,9 +268,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1082,6 +1082,21 @@ dimensions = () type = integer intent = in +[spp_wts_gwd] + standard_name = spp_weights_for_gravity_wave_drag_scheme + long_name = spp weights for gravity wave drag scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_gwd] + standard_name = control_for_gravity_wave_drag_spp_perturbations + long_name = control for gravity wave drag spp perturbations + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1091,9 +1106,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/ugwpv1_gsldrag_post.meta b/physics/ugwpv1_gsldrag_post.meta index 2021fdb42..4a0e88de9 100644 --- a/physics/ugwpv1_gsldrag_post.meta +++ b/physics/ugwpv1_gsldrag_post.meta @@ -269,9 +269,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index da79ecde8..9e93bd5fc 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -218,7 +218,7 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, index_of_process_orographic_gwd, index_of_process_nonorographic_gwd, & ldiag3d, lssav, flag_for_gwd_generic_tend, do_ugwp_v0, do_ugwp_v0_orog_only, & do_ugwp_v0_nst_only, do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd, & - gwd_opt, errmsg, errflg) + gwd_opt, spp_wts_gwd, spp_gwd, errmsg, errflg) implicit none @@ -296,6 +296,9 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do_gsl_drag_ls_bl, do_gsl_drag_ss, & do_gsl_drag_tofd + real(kind=kind_phys), intent(in) :: spp_wts_gwd(:,:) + integer, intent(in) :: spp_gwd + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -343,7 +346,8 @@ subroutine unified_ugwp_run(me, master, im, levs, ntrac, dtp, fhzero, kdt, do_gsl_drag_ls_bl,do_gsl_drag_ss,do_gsl_drag_tofd, & dtend, dtidx, index_of_process_orographic_gwd, & index_of_temperature, index_of_x_wind, & - index_of_y_wind, ldiag3d, errmsg, errflg) + index_of_y_wind, ldiag3d, spp_wts_gwd, spp_gwd, & + errmsg, errflg) ! ! put zeros due to xy GSL-drag style: dtaux2d_bl,dtauy2d_bl,dtaux2d_ss.......dusfc_ls,dvsfc_ls ! diff --git a/physics/unified_ugwp.meta b/physics/unified_ugwp.meta index fbdf3d00e..2ff65e3d3 100644 --- a/physics/unified_ugwp.meta +++ b/physics/unified_ugwp.meta @@ -86,7 +86,7 @@ standard_name = sigma_pressure_hybrid_coordinate_a_coefficient long_name = a parameter for sigma pressure level calculations units = Pa - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -94,7 +94,7 @@ standard_name = sigma_pressure_hybrid_coordinate_b_coefficient long_name = b parameter for sigma pressure level calculations units = none - dimensions = (vertical_interface_dimension_for_radiation) + dimensions = (vertical_interface_dimension) type = real kind = kind_phys intent = in @@ -227,9 +227,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -261,9 +261,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -1178,6 +1178,21 @@ dimensions = () type = integer intent = in +[spp_wts_gwd] + standard_name = spp_weights_for_gravity_wave_drag_scheme + long_name = spp weights for gravity wave drag scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[spp_gwd] + standard_name = control_for_gravity_wave_drag_spp_perturbations + long_name = control for gravity wave drag spp perturbations + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1187,9 +1202,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/unified_ugwp_post.meta b/physics/unified_ugwp_post.meta index e2723821b..1df5cc5b5 100644 --- a/physics/unified_ugwp_post.meta +++ b/physics/unified_ugwp_post.meta @@ -269,9 +269,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out diff --git a/physics/ysuvdif.meta b/physics/ysuvdif.meta index f28ef3eff..0007197bd 100644 --- a/physics/ysuvdif.meta +++ b/physics/ysuvdif.meta @@ -23,9 +23,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out @@ -511,9 +511,9 @@ kind = len=* intent = out [errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 dimensions = () type = integer intent = out