From a0fb86dec6bf53301fae020f55e3ca61d0fd4eb9 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 17 Oct 2019 18:54:18 +0000 Subject: [PATCH 01/91] github version of latest branch --- atmos_model.F90 | 30 +- fv3_cap.F90 | 6 +- gfsphysics/GFS_layer/GFS_driver.F90 | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 44 +-- gfsphysics/GFS_layer/GFS_radiation_driver.F90 | 16 +- gfsphysics/GFS_layer/GFS_typedefs.F90 | 34 +- gfsphysics/physics/cires_ugwp_initialize.F90 | 20 +- gfsphysics/physics/cires_ugwp_triggers.F90 | 52 +-- gfsphysics/physics/dcyc2.f | 2 +- gfsphysics/physics/gcm_shoc.f90 | 138 ++++---- gfsphysics/physics/gwdps.f | 20 +- gfsphysics/physics/sfc_nst.f | 4 +- gfsphysics/physics/sfc_sice.f | 2 +- gfsphysics/physics/ugwp_driver_v0.f | 326 +++++++++--------- io/FV3GFS_io.F90 | 9 +- 15 files changed, 360 insertions(+), 345 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 23e30e76c..620366227 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1566,6 +1566,7 @@ subroutine assign_importdata(rc) ! implicit none integer, intent(out) :: rc + real(kind=IPD_kind_phys), parameter :: epsln=1.0d-10 !--- local variables integer :: n, j, i, ix, nb, isc, iec, jsc, jec, dimCount, findex @@ -1652,7 +1653,9 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - IPD_Data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) + if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then + IPD_Data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) + endif enddo enddo endif @@ -1696,19 +1699,16 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) IPD_Data(nb)%Coupling%ficein_cpl(ix) = zero + IPD_Data(nb)%Coupling%slimskin_cpl(ix) = IPD_Data(nb)%Sfcprop%slmsk(ix) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then if (datar8(i,j) >= IPD_control%min_seaice*IPD_Data(nb)%Sfcprop%oceanfrac(ix)) then IPD_Data(nb)%Coupling%ficein_cpl(ix) = datar8(i,j) -! if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) == one) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4. else - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) == one) IPD_Data(nb)%Sfcprop%slmsk(ix) = zero + if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero endif - else - IPD_Data(nb)%Sfcprop%slmsk(ix) = one - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = one endif enddo enddo @@ -1884,6 +1884,7 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) else + IPD_Data(nb)%Sfcprop%tisfc(ix) = max(IPD_Data(nb)%Coupling%tseain_cpl(ix), 271.2) IPD_Data(nb)%Sfcprop%fice(ix) = zero IPD_Data(nb)%Sfcprop%hice(ix) = zero IPD_Data(nb)%Sfcprop%snowd(ix) = zero @@ -1894,12 +1895,27 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Coupling%dvsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%ulwsfcin_cpl(ix) = -99999.0 ! ,, - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) == one) IPD_Data(nb)%Sfcprop%slmsk(ix) = zero ! 100% open water endif endif enddo enddo endif +!------------------------------------------------------------------------------- +! do j=jsc,jec +! do i=isc,iec +! nb = Atm_block%blkno(i,j) +! ix = Atm_block%ixp(i,j) +! if (abs(IPD_Data(nb)%Grid%xlon_d(ix)-2.89) < 0.1 .and. & +! abs(IPD_Data(nb)%Grid%xlat_d(ix)+58.99) < 0.1) then +! write(0,*)' in assign tisfc=',IPD_Data(nb)%Sfcprop%tisfc(ix), & +! ' oceanfrac=',IPD_Data(nb)%Sfcprop%oceanfrac(ix),' i=',i,' j=',j,& +! ' tisfcin=',IPD_Data(nb)%Coupling%tisfcin_cpl(ix), & +! ' fice=',IPD_Data(nb)%Sfcprop%fice(ix) +! endif +! enddo +! enddo +!------------------------------------------------------------------------------- +! rc=0 ! diff --git a/fv3_cap.F90 b/fv3_cap.F90 index e8e482099..657584e5e 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -30,7 +30,7 @@ module fv3gfs_cap_mod calendar, calendar_type, cpl, & force_date_from_configure, & cplprint_flag,output_1st_tstep_rst, & - first_kdt + first_kdt use module_fv3_io_def, only: num_pes_fcst,write_groups, & num_files, filename_base, & @@ -1274,7 +1274,7 @@ subroutine ModelAdvance_phase2(gcomp, rc) rc = ESMF_SUCCESS if(profile_memory) & call ESMF_VMLogMemInfo("Entering FV3 Model_ADVANCE phase2: ") -! +! call ESMF_GridCompGet(gcomp, name=name, localpet=mype, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1285,7 +1285,7 @@ subroutine ModelAdvance_phase2(gcomp, rc) ! !*** for forecast tasks - + timewri = mpi_wtime() call ESMF_LogWrite('Model Advance phase2: before fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) diff --git a/gfsphysics/GFS_layer/GFS_driver.F90 b/gfsphysics/GFS_layer/GFS_driver.F90 index 3b6a94336..e73343782 100644 --- a/gfsphysics/GFS_layer/GFS_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_driver.F90 @@ -445,7 +445,7 @@ end subroutine GFS_initialize ! 5) interpolates coefficients for prognostic ozone calculation ! 6) performs surface data cycling via the GFS gcycle routine !------------------------------------------------------------------------- - subroutine GFS_time_vary_step (Model, Statein, Stateout, Sfcprop, Coupling, & + subroutine GFS_time_vary_step (Model, Statein, Stateout, Sfcprop, Coupling, & Grid, Tbd, Cldprop, Radtend, Diag) implicit none diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index a54716960..76c6590d6 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -2656,33 +2656,33 @@ subroutine GFS_physics_driver & if (ntgl > 0) then ! MG do k=1,levs do i=1,im - dqdt(i,k,1) = vdftra(i,k,1) - dqdt(i,k,ntcw) = vdftra(i,k,2) - dqdt(i,k,ntiw) = vdftra(i,k,3) - dqdt(i,k,ntrw) = vdftra(i,k,4) - dqdt(i,k,ntsw) = vdftra(i,k,5) - dqdt(i,k,ntgl) = vdftra(i,k,6) - dqdt(i,k,ntlnc) = vdftra(i,k,7) - dqdt(i,k,ntinc) = vdftra(i,k,8) - dqdt(i,k,ntrnc) = vdftra(i,k,9) - dqdt(i,k,ntsnc) = vdftra(i,k,10) - dqdt(i,k,ntgnc) = vdftra(i,k,11) - dqdt(i,k,ntoz) = vdftra(i,k,12) + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntgl) = dvdftra(i,k,6) + dqdt(i,k,ntlnc) = dvdftra(i,k,7) + dqdt(i,k,ntinc) = dvdftra(i,k,8) + dqdt(i,k,ntrnc) = dvdftra(i,k,9) + dqdt(i,k,ntsnc) = dvdftra(i,k,10) + dqdt(i,k,ntgnc) = dvdftra(i,k,11) + dqdt(i,k,ntoz) = dvdftra(i,k,12) enddo enddo else ! MG2 do k=1,levs do i=1,im - dqdt(i,k,1) = vdftra(i,k,1) - dqdt(i,k,ntcw) = vdftra(i,k,2) - dqdt(i,k,ntiw) = vdftra(i,k,3) - dqdt(i,k,ntrw) = vdftra(i,k,4) - dqdt(i,k,ntsw) = vdftra(i,k,5) - dqdt(i,k,ntlnc) = vdftra(i,k,6) - dqdt(i,k,ntinc) = vdftra(i,k,7) - dqdt(i,k,ntrnc) = vdftra(i,k,8) - dqdt(i,k,ntsnc) = vdftra(i,k,9) - dqdt(i,k,ntoz) = vdftra(i,k,10) + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntlnc) = dvdftra(i,k,6) + dqdt(i,k,ntinc) = dvdftra(i,k,7) + dqdt(i,k,ntrnc) = dvdftra(i,k,8) + dqdt(i,k,ntsnc) = dvdftra(i,k,9) + dqdt(i,k,ntoz) = dvdftra(i,k,10) enddo enddo endif diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 index c7323d6bb..e912014ef 100644 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 @@ -1871,30 +1871,30 @@ subroutine GFS_radiation_driver & ! print *,' in grrad : calling swrad' if (Model%swhtr) then - call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs + call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs gasvmr, clouds, Tbd%icsdsw, faersw, & sfcalb, dz, delp, de_lgth, & Radtend%coszen, Model%solcon, & nday, idxday, im, lmk, lmp, Model%lprnt,& - htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs + htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs cldtausw, & hsw0=htsw0, fdncmp=scmpsw) ! --- optional else - call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs + call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs gasvmr, clouds, Tbd%icsdsw, faersw, & sfcalb, dz, delp, de_lgth, & Radtend%coszen, Model%solcon, & nday, idxday, IM, LMK, LMP, Model%lprnt,& - htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs + htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs cldtausw, & - FDNCMP=scmpsw) ! --- optional + FDNCMP=scmpsw) ! --- optional endif do k = 1, LM k1 = k + kd Radtend%htrsw(1:im,k) = htswc(1:im,k1) enddo -! We are assuming that radiative tendencies are from bottom to top +! We are assuming that radiative tendencies are from bottom to top ! --- repopulate the points above levr i.e. LM if (lm < levs) then do k = lm,levs @@ -1910,7 +1910,7 @@ subroutine GFS_radiation_driver & ! --- repopulate the points above levr i.e. LM if (lm < levs) then do k = lm,levs - Radtend%swhc(1:im,k) = Radtend%swhc(1:im,LM) + Radtend%swhc(1:im,k) = Radtend%swhc(1:im,LM) enddo endif endif @@ -1973,7 +1973,7 @@ subroutine GFS_radiation_driver & call setemis (Grid%xlon, Grid%xlat, Sfcprop%slmsk, & ! --- inputs Sfcprop%snowd, Sfcprop%sncovr, Sfcprop%zorl, & - tsfg, tsfa, Sfcprop%hprime(:,1), IM, & + tsfg, tsfa, Sfcprop%hprime(:,1), IM, & Radtend%semis) ! --- outputs !> - Call module_radlw_main::lwrad(), to compute LW heating rates and diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 65f6d30de..7ea1b598f 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -228,12 +228,12 @@ module GFS_typedefs !< [tsea in gbphys.f] real (kind=kind_phys), pointer :: tsfco (:) => null() !< sst in K real (kind=kind_phys), pointer :: tsfcl (:) => null() !< surface land temperature in K - real (kind=kind_phys), pointer :: tisfc (:) => null() !< surface temperature over ice fraction + real (kind=kind_phys), pointer :: tisfc (:) => null() !< surface temperature over ice fraction real (kind=kind_phys), pointer :: snowd (:) => null() !< snow depth water equivalent in mm ; same as snwdph - real (kind=kind_phys), pointer :: zorl (:) => null() !< composite surface roughness in cm - real (kind=kind_phys), pointer :: zorlo (:) => null() !< ocean surface roughness in cm - real (kind=kind_phys), pointer :: zorll (:) => null() !< land surface roughness in cm - real (kind=kind_phys), pointer :: fice (:) => null() !< ice fraction over open water grid + real (kind=kind_phys), pointer :: zorl (:) => null() !< composite surface roughness in cm + real (kind=kind_phys), pointer :: zorlo (:) => null() !< ocean surface roughness in cm + real (kind=kind_phys), pointer :: zorll (:) => null() !< land surface roughness in cm + real (kind=kind_phys), pointer :: fice (:) => null() !< ice fraction over open water grid ! real (kind=kind_phys), pointer :: hprim (:) => null() !< topographic standard deviation in m real (kind=kind_phys), pointer :: hprime (:,:) => null() !< orographic metrics @@ -571,7 +571,7 @@ module GFS_typedefs logical :: cplchm !< default no cplchm collection !--- integrated dynamics through earth's atmosphere - logical :: lsidea + logical :: lsidea !vay 2018 GW physics switches @@ -865,7 +865,7 @@ module GFS_typedefs !< cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) !< Nccn: CCN number concentration in cm^(-3) !< Until a realistic Nccn is provided, Nccns are assumed - !< as Nccn=100 for sea and Nccn=1000 for land + !< as Nccn=100 for sea and Nccn=1000 for land !--- near surface temperature model logical :: nst_anl !< flag for NSSTM analysis in gcycle/sfcsub @@ -885,7 +885,7 @@ module GFS_typedefs real(kind=kind_phys) :: rho_h2o !< density of fresh water !--- surface layer z0 scheme - integer :: sfc_z0_type !< surface roughness options over ocean: + integer :: sfc_z0_type !< surface roughness options over ocean: !< 0=no change !< 6=areodynamical roughness over water with input 10-m wind !< 7=slightly decrease Cd for higher wind speed compare to 6 @@ -951,7 +951,7 @@ module GFS_typedefs integer :: ntke !< tracer index for kinetic energy integer :: nto !< tracer index for oxygen ion integer :: nto2 !< tracer index for oxygen - integer :: ntwa !< tracer index for water friendly aerosol + integer :: ntwa !< tracer index for water friendly aerosol integer :: ntia !< tracer index for ice friendly aerosol integer :: ntchm !< number of chemical tracers integer :: ntchs !< tracer index for first chemical tracer @@ -2484,7 +2484,7 @@ subroutine coupling_create (Coupling, IM, Model) endif !--- needed for Thompson's aerosol option - if(Model%imp_physics == Model%imp_physics_thompson .and. Model%ltaerosol) then + if(Model%imp_physics == Model%imp_physics_thompson .and. Model%ltaerosol) then allocate (Coupling%nwfa2d (IM)) allocate (Coupling%nifa2d (IM)) Coupling%nwfa2d = clear_val @@ -2881,6 +2881,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: xkzminv = 0.3 !< diffusivity in inversion layers real(kind=kind_phys) :: moninq_fac = 1.0 !< turbulence diffusion coefficient factor real(kind=kind_phys) :: dspfac = 1.0 !< tke dissipative heating factor + real(kind=kind_phys) :: bl_upfr = 0.13 !< updraft fraction in boundary layer mass flux scheme real(kind=kind_phys) :: bl_dnfr = 0.1 !< downdraft fraction in boundary layer mass flux scheme @@ -2894,12 +2895,11 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer :: iseed_ca = 0 integer :: nspinup = 1 logical :: do_ca = .false. - logical :: ca_sgs = .false. + logical :: ca_sgs = .false. logical :: ca_global = .false. logical :: ca_smooth = .false. logical :: isppt_deep = .false. real(kind=kind_phys) :: nthresh = 0.0 - !--- IAU options real(kind=kind_phys) :: iau_delthrs = 0 !< iau time interval (to scale increments) @@ -4896,12 +4896,12 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%dv3dt (IM,Model%levs,4)) allocate (Diag%dt3dt (IM,Model%levs,7)) allocate (Diag%dq3dt (IM,Model%levs,9)) -! allocate (Diag%dq3dt (IM,Model%levs,oz_coeff+5)) +! allocate (Diag%dq3dt (IM,Model%levs,oz_coeff+5)) !--- needed to allocate GoCart coupling fields -! allocate (Diag%upd_mf (IM,Model%levs)) -! allocate (Diag%dwn_mf (IM,Model%levs)) -! allocate (Diag%det_mf (IM,Model%levs)) -! allocate (Diag%cldcov (IM,Model%levs)) +! allocate (Diag%upd_mf (IM,Model%levs)) +! allocate (Diag%dwn_mf (IM,Model%levs)) +! allocate (Diag%det_mf (IM,Model%levs)) +! allocate (Diag%cldcov (IM,Model%levs)) endif !vay-2018 diff --git a/gfsphysics/physics/cires_ugwp_initialize.F90 b/gfsphysics/physics/cires_ugwp_initialize.F90 index fbcc1d205..fd2a32d6b 100644 --- a/gfsphysics/physics/cires_ugwp_initialize.F90 +++ b/gfsphysics/physics/cires_ugwp_initialize.F90 @@ -30,11 +30,11 @@ ! oro_stat(i,12) = gamm(i) ! oro_stat(i,13) = sigma(i) ! oro_stat(i,14) = elvmax(i) -! enddo +! enddo ! end subroutine fill_oro_stat ! end module oro_state - + module ugwp_common ! use machine, only: kind_phys @@ -181,7 +181,7 @@ module ugwp_oro_init real, parameter :: rlolev=50000.0 ! real, parameter :: hncrit=9000. ! max value in meters for elvmax - + ! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt real, parameter :: sigfac=4.0 ! mb3a expt test for elvmax factor @@ -514,7 +514,7 @@ end module ugwp_lsatdis_init ! ! module ugwp_wmsdis_init - + use ugwp_common, only : pi, pi2 implicit none @@ -528,7 +528,7 @@ module ugwp_wmsdis_init real, parameter :: gssec = (6.28/30.)**2 ! max-value for bn2 real, parameter :: bv2min = (6.28/60./120.)**2 ! min-value for bn2 7.6(-7) 2 hrs real, parameter :: minvel = 0.5 - + ! ! make parameter list that will be passed to SOLVER ! @@ -541,11 +541,11 @@ module ugwp_wmsdis_init real , parameter :: nslope=1 ! the GW sprctral slope at small-m ! integer, parameter :: klaunch=55 ! 32 - ~ 1km ;55 - 5.5 km ; 52 4.7km ; 60-7km index for selecting launch level ! integer, parameter :: ilaunch=klaunch - + integer , parameter :: iazidim=4 ! number of azimuths integer , parameter :: incdim=25 ! number of discrete cx - spectral elements in launch spectrum real , parameter :: ucrit2=0.5 - + real , parameter :: zcimin = ucrit2 real , parameter :: zcimax = 125.0 real , parameter :: zgam = 0.25 @@ -553,18 +553,18 @@ module ugwp_wmsdis_init integer :: ilaunch real :: gw_eff - + !=========================================================================== integer :: nwav, nazd, nst real :: eff - + real :: zaz_fct real, allocatable :: zci(:), zci4(:), zci3(:),zci2(:), zdci(:) real, allocatable :: zcosang(:), zsinang(:) contains !============================================================================ subroutine initsolv_wmsdis(me, master, nwaves, nazdir, nstoch, effac, do_physb, kxw) - + ! call initsolv_wmsdis(me, master, knob_ugwp_wvspec(2), knob_ugwp_azdir(2), & ! knob_ugwp_stoch(2), knob_ugwp_effac(2), do_physb_gwsrcs, kxw) ! diff --git a/gfsphysics/physics/cires_ugwp_triggers.F90 b/gfsphysics/physics/cires_ugwp_triggers.F90 index bb135b857..4c03d9c9d 100644 --- a/gfsphysics/physics/cires_ugwp_triggers.F90 +++ b/gfsphysics/physics/cires_ugwp_triggers.F90 @@ -10,8 +10,8 @@ SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & implicit none integer :: nx, ny real :: lon(nx), lat(ny) - real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) - real :: rlatc(ny-1), brcos(ny), brcos2(ny) + real :: rlon(nx), rlat(ny) , cosv(ny), tanlat(ny) + real :: rlatc(ny-1), brcos(ny), brcos2(ny) real :: earth_r, ra1, ra2, dx, dy, dlat real :: dlam1(ny), dlam2(ny), divJp(ny), divJm(ny) integer :: j @@ -27,7 +27,7 @@ SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & rlat = lat*deg_to_rad rlon = lon*deg_to_rad tanlat = atan(rlat) - cosv = cos(rlat) + cosv = cos(rlat) dy = rlat(2)-rlat(1) dx = rlon(2)-rlon(1) ! @@ -37,17 +37,17 @@ SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & ! do j=2, ny-1 brcos(j) = 1.0 / cos(rlat(j))*ra1 - enddo - + enddo + brcos(1) = brcos(2) brcos(ny) = brcos(ny-1) brcos2 = brcos*brcos ! dlam1 = brcos / (dx+dx) dlam2 = brcos2 / (dx*dx) - + dlat = ra1 / (dy+dy) - + divJp = dlat*cosv divJM = dlat*cosv ! @@ -62,12 +62,12 @@ SUBROUTINE subs_diag_geo(nx, ny, lat, lon, rlat, rlon, dy, dx, & ! return end SUBROUTINE subs_diag_geo -! +! subroutine get_xy_pt(V, Vx, Vy, nx, ny, dlam1, dlat) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! compute for each Vert-column: grad(V) ! periodic in X and central diff ... -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ implicit none integer :: nx, ny real :: V(nx, ny), dlam1(ny), dlat @@ -438,7 +438,7 @@ subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, t print *, ' get_spectra_tau_okwgw ' do i=1, im k = klow - klev(i) = k + klev(i) = k dmax = abs(trig_okw(i,k)) kex = 0 if (dmax >= tlim_okw) kex = kex+1 @@ -448,16 +448,16 @@ subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, t if ( dtot > dmax) then klev(i) = k dmax = dtot - endif + endif enddo -! +! if (dmax >= tlim_okw) then nf_src = nf_src + 1 if_src(i) = 1 taub(i) = tau_min*float(kex) !* precip(i)/precip_max*coslat(i) endif - enddo + enddo print *, ' get_spectra_tau_okwgw ' end subroutine get_spectra_tau_okw ! @@ -468,16 +468,16 @@ subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) ! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* !================= implicit none - integer :: im + integer :: im real :: tau_amp, xlatdeg(im), tau_gw(im) real :: latdeg, flat_gw, tem integer :: i - + ! ! if-lat ! do i=1, im - latdeg = abs(xlatdeg(i)) + latdeg = abs(xlatdeg(i)) if (latdeg < 15.3) then tem = (latdeg-3.0) / 8.0 flat_gw = 0.75 * exp(-tem * tem) @@ -491,22 +491,22 @@ subroutine slat_geos5_tamp(im, tau_amp, xlatdeg, tau_gw) tem = (latdeg-60.0) / 70.0 flat_gw = 0.50 * exp(- tem * tem) endif - tau_gw(i) = tau_amp*flat_gw + tau_gw(i) = tau_amp*flat_gw enddo -! +! end subroutine slat_geos5_tamp - + subroutine slat_geos5(im, xlatdeg, tau_gw) !================= ! GEOS-5 & MERRA-2 lat-dependent GW-source function tau(z=Zlaunch) =rho* !================= implicit none - integer :: im - real :: xlatdeg(im) + integer :: im + real :: xlatdeg(im) real :: tau_gw(im) real :: latdeg real, parameter :: tau_amp = 100.e-3 - real :: trop_gw, flat_gw + real :: trop_gw, flat_gw integer :: i ! ! if-lat @@ -532,7 +532,7 @@ subroutine slat_geos5(im, xlatdeg, tau_gw) end if tau_gw(i) = tau_amp*flat_gw enddo -! +! end subroutine slat_geos5 subroutine init_nazdir(naz, xaz, yaz) use ugwp_common , only : pi2 @@ -542,7 +542,7 @@ subroutine init_nazdir(naz, xaz, yaz) integer :: idir real :: phic, drad drad = pi2/float(naz) - if (naz.ne.4) then + if (naz.ne.4) then do idir =1, naz Phic = drad*(float(idir)-1.0) xaz(idir) = cos(Phic) @@ -552,11 +552,11 @@ subroutine init_nazdir(naz, xaz, yaz) ! if (naz.eq.4) then xaz(1) = 1.0 !E yaz(1) = 0.0 - xaz(2) = 0.0 + xaz(2) = 0.0 yaz(2) = 1.0 !N xaz(3) =-1.0 !W yaz(3) = 0.0 xaz(4) = 0.0 yaz(4) =-1.0 !S - endif + endif end subroutine init_nazdir diff --git a/gfsphysics/physics/dcyc2.f b/gfsphysics/physics/dcyc2.f index 9c8474ae4..1c33e4f3e 100644 --- a/gfsphysics/physics/dcyc2.f +++ b/gfsphysics/physics/dcyc2.f @@ -218,7 +218,7 @@ subroutine dcyc2t3 & enddo else rstl = one / float(nstl) - solang = pid12 * (solhr - hour12) + solang = pid12 * (solhr - hour12) anginc = pid12 * deltim * f3600 * rstl do i = 1, im xcosz(i) = zero diff --git a/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 index e48f4e3e4..ff9391db1 100644 --- a/gfsphysics/physics/gcm_shoc.f90 +++ b/gfsphysics/physics/gcm_shoc.f90 @@ -35,7 +35,7 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & lfus => con_hfus, & ! Latent heat of fusion, J/kg rv => con_rv, & ! Gas constant for water vapor, J/kg/K rgas => con_rd, & ! Gas constant for dry air, J/kg/K - pi => con_pi, & ! Pi + pi => con_pi, & ! Pi epsv => con_fvirt implicit none @@ -62,25 +62,25 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & integer, intent(in) :: lat ! latitude integer, intent(in) :: nzm ! Number of vertical layers - integer, intent(in) :: nz ! Number of layer interfaces (= nzm + 1) + integer, intent(in) :: nz ! Number of layer interfaces (= nzm + 1) integer, intent(in) :: imp_phys! microphysics identifier - real, intent(in) :: dtn ! Physics time step, s + real, intent(in) :: dtn ! Physics time step, s real, intent(in) :: pcrit ! pressure in Pa below which additional tke dissipation is applied real, intent(in) :: cefac ! tunable multiplier to dissipation term real, intent(in) :: cesfac ! tunable multiplier to dissipation term for bottom level real, intent(in) :: tkef1 ! uncentering terms in implicit tke integration real, intent(in) :: dis_opt ! when > 0 use different formula for near surface dissipation - + real, intent(in) :: hflx(nx) real, intent(in) :: evap(nx) ! The interface is talored to GFS in a sense that input variables are 2D - real, intent(in) :: prsl (ix,nzm) ! mean layer presure - real, intent(in) :: delp (ix,nzm) ! layer presure depth + real, intent(in) :: prsl (ix,nzm) ! mean layer presure + real, intent(in) :: delp (ix,nzm) ! layer presure depth real, intent(in) :: phii (ix,nz ) ! interface geopotential height - real, intent(in) :: phil (ix,nzm) ! layer geopotential height + real, intent(in) :: phil (ix,nzm) ! layer geopotential height real, intent(in) :: u (ix,nzm) ! u-wind, m/s real, intent(in) :: v (ix,nzm) ! v-wind, m/s real, intent(in) :: omega (ix,nzm) ! omega, Pa/s @@ -108,12 +108,12 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & ! SHOC tunable parameters real, parameter :: lambda = 0.04d0 -! real, parameter :: min_tke = 1.0d-6 ! Minumum TKE value, m**2/s**2 - real, parameter :: min_tke = 1.0d-4 ! Minumum TKE value, m**2/s**2 -! real, parameter :: max_tke = 100.0d0 ! Maximum TKE value, m**2/s**2 - real, parameter :: max_tke = 40.0d0 ! Maximum TKE value, m**2/s**2 +! real, parameter :: min_tke = 1.0d-6 ! Minumum TKE value, m**2/s**2 + real, parameter :: min_tke = 1.0d-4 ! Minumum TKE value, m**2/s**2 +! real, parameter :: max_tke = 100.0d0 ! Maximum TKE value, m**2/s**2 + real, parameter :: max_tke = 40.0d0 ! Maximum TKE value, m**2/s**2 ! Maximum turbulent eddy length scale, m -! real, parameter :: max_eddy_length_scale = 2000.0d0 +! real, parameter :: max_eddy_length_scale = 2000.0d0 real, parameter :: max_eddy_length_scale = 1000.0d0 ! Maximum "return-to-isotropy" time scale, s real, parameter :: max_eddy_dissipation_time_scale = 2000.d0 @@ -122,13 +122,13 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & ! Constants for the TKE dissipation term based on Deardorff (1980) real, parameter :: pt19=0.19d0, pt51=0.51d0, pt01=0.01d0, atmin=0.01d0, atmax=one-atmin real, parameter :: Cs = 0.15d0, epsln=1.0d-6 -! real, parameter :: Ck = 0.2d0 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 +! real, parameter :: Ck = 0.2d0 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 real, parameter :: Ck = 0.1d0 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 -! real, parameter :: Ce = Ck**3/(0.7*Cs**4) -! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.2 -! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 3.0 , Ces = Ce -! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.5 , Ces = Ce * 3.0 / 2.5 +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.2 +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 3.0 , Ces = Ce +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.5 , Ces = Ce * 3.0 / 2.5 ! real, parameter :: Ces = Ce/0.7*3.0 ! real, parameter :: Ce = Ck**3/(0.7*Cs**4), Ces = Ce*3.0/0.7 ! Commented Moor @@ -168,7 +168,7 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & real zi (nx,nz) ! height of the interface levels, m real adzl (nx,nzm) ! layer thickness i.e. zi(k+1)-zi(k) - defined at levels real adzi (nx,nz) ! level thickness i.e. zl(k)-zl(k-1) - defined at interface - + real hl (nx,nzm) ! liquid/ice water static energy , K real qv (nx,nzm) ! water vapor, kg/kg real qcl (nx,nzm) ! liquid water (condensate), kg/kg @@ -449,7 +449,7 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & subroutine tke_shoc() -! This subroutine solves the TKE equation, +! This subroutine solves the TKE equation, ! Heavily based on SAM's tke_full.f90 by Marat Khairoutdinov real grd,betdz,Cee,lstarn, lstarp, bbb, omn, omp,qsatt,dqsat, smix, & @@ -476,10 +476,10 @@ subroutine tke_shoc() call check_eddy() ! Make sure it's reasonable tkef2 = 1.0 - tkef1 - do k=1,nzm + do k=1,nzm ku = k+1 kd = k - + ! Cek = Ce * cefac if(k == 1) then @@ -619,7 +619,7 @@ subroutine tke_shear_prod(def2) real rdzw, wrku, wrkv, wrkw integer i,k,k1 - + ! Calculate TKE shear production term at layer interface do k=2,nzm @@ -686,7 +686,7 @@ subroutine eddy_length() l_inf(i) = 100.0d0 endif enddo - + !Calculate length scale outside of cloud, Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) do k=1,nzm @@ -744,14 +744,14 @@ subroutine eddy_length() brunt(i,k) = betdz*(bbb*(hl(i,kc)-hl(i,kb)) & + (bbb*lstarn - (one+lstarn*dqsat)*tabs(i,k)) & - * (total_water(i,kc)-total_water(i,kb)) & + * (total_water(i,kc)-total_water(i,kb)) & + (bbb*fac_cond - (one+fac_cond*dqsat)*tabs(i,k))*(qpl(i,kc)-qpl(i,kb)) & + (bbb*fac_sub - (one+fac_sub*dqsat)*tabs(i,k))*(qpi(i,kc)-qpi(i,kb)) ) else ! outside of cloud ! Find outside-of-cloud Brunt-Vaisalla frequency -! Only unsaturated air, rain and snow contribute to virt. pot. temp. +! Only unsaturated air, rain and snow contribute to virt. pot. temp. ! liquid/ice moist static energy divided by cp? bbb = one + epsv*qv(i,k) - qpl(i,k) - qpi(i,k) @@ -760,16 +760,16 @@ subroutine eddy_length() + (bbb*fac_cond-tabs(i,k))*(qpl(i,kc)-qpl(i,kb)) & + (bbb*fac_sub -tabs(i,k))*(qpi(i,kc)-qpi(i,kb)) ) endif - + ! Reduction of mixing length in the stable regions (where B.-V. freq. > 0) is required. -! Here we find regions of Brunt-Vaisalla freq. > 0 for later use. +! Here we find regions of Brunt-Vaisalla freq. > 0 for later use. if (brunt(i,k) >= zero) then brunt2(i,k) = brunt(i,k) else brunt2(i,k) = zero endif - + ! Calculate turbulent length scale in the boundary layer. ! See Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) @@ -781,8 +781,8 @@ subroutine eddy_length() ! smixt(i,k) = term + (0.4*zl(i,k)-term)*exp(-zl(i,k)*0.01) ! else -! tscale is the eddy turnover time scale in the boundary layer and is -! an empirically derived constant +! tscale is the eddy turnover time scale in the boundary layer and is +! an empirically derived constant if (tkes > zero .and. l_inf(i) > zero) then wrk1 = one / (tscale*tkes*vonk*zl(i,k)) @@ -792,19 +792,19 @@ subroutine eddy_length() ! smixt(i,k) = min(max_eddy_length_scale, 2.8284*sqrt(wrk1)/0.3) smixt(i,k) = min(max_eddy_length_scale, wrk1) -! smixt(i,k) = min(max_eddy_length_scale,(2.8284*sqrt(1./((1./(tscale*tkes*vonk*zl(i,k))) & +! smixt(i,k) = min(max_eddy_length_scale,(2.8284*sqrt(1./((1./(tscale*tkes*vonk*zl(i,k))) & ! + (1./(tscale*tkes*l_inf(i)))+0.01*(brunt2(i,k)/tke(i,k)))))/0.3) ! else ! smixt(i,k) = zero endif - + ! endif - - + + enddo enddo - - + + ! Now find the in-cloud turbulence length scale ! See Eq. 13 in BK13 (Eq. 4.18 in Pete's disseration) @@ -812,7 +812,7 @@ subroutine eddy_length() ! Remove after coupling to subgrid PDF. !wthv_sec = -300/ggr*brunt*tk !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - + ! determine cubed convective velocity scale (conv_vel2) inside the cloud ! call conv_scale() ! inlining the relevant code @@ -863,12 +863,11 @@ subroutine eddy_length() conv_var = conv_var+ 2.5d0*adzi(i,kk)*bet(i,kk)*wthv_sec(i,kk) enddo conv_var = conv_var ** oneb3 - + if (conv_var > 0) then ! If convective vertical velocity scale > 0 depth = (zl(i,ku)-zl(i,kl)) + adzl(i,kl) - - + do kk=kl,ku ! in-cloud turbulence length scale, Eq. 13 in BK13 (Eq. 4.18) @@ -890,14 +889,14 @@ subroutine eddy_length() enddo ! k=2,nzm-3 endif ! if in the cloudy column enddo ! i=1,nx - - + + end subroutine eddy_length subroutine conv_scale() -! This subroutine calculates the cubed convective velocity scale needed +! This subroutine calculates the cubed convective velocity scale needed ! for the definition of the length scale in clouds ! See Eq. 16 in BK13 (Eq. 4.21 in Pete's dissertation) @@ -908,7 +907,7 @@ subroutine conv_scale() ! Obtain it by averaging conv_vel2 in the horizontal !!!!!!!!!! -! conv_vel(1)=zero ! Horizontally averaged convective velocity scale cubed +! conv_vel(1)=zero ! Horizontally averaged convective velocity scale cubed do i=1,nx conv_vel2(i,1) = zero ! Convective velocity scale cubed enddo @@ -917,10 +916,10 @@ subroutine conv_scale() ! conv_vel(k)=conv_vel(k-1) do i=1,nx !********************************************************************** -!Do not include grid-scale contribution to convective velocity scale in GCM applications +!Do not include grid-scale contribution to convective velocity scale in GCM applications ! conv_vel(k)=conv_vel(k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+tvws(k)) ! conv_vel(k)=conv_vel(k)+2.5*adzi(i,k)*bet(i,k)*(tvws(k)) -!Do not include grid-scale contribution to convective velocity scale in GCM applications +!Do not include grid-scale contribution to convective velocity scale in GCM applications ! conv_vel2(i,k)=conv_vel2(i,k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+wthv_sec(i,k)) !********************************************************************** @@ -934,7 +933,7 @@ end subroutine conv_scale subroutine check_eddy() -! This subroutine checks eddy length values +! This subroutine checks eddy length values integer i, k, kb, ks, zend real wrk @@ -958,11 +957,11 @@ subroutine check_eddy() wrk = 0.1*adzl(i,k) ! Minimum 0.1 of local dz - smixt(i,k) = max(wrk, min(max_eddy_length_scale,smixt(i,k))) + smixt(i,k) = max(wrk, min(max_eddy_length_scale,smixt(i,k))) ! If chracteristic grid dimension in the horizontal< 1000m, set lengthscale to -! be not larger that that. -! if (sqrt(dx*dy) .le. 1000.) smixt(i,k)=min(sqrt(dx*dy),smixt(i,k)) +! be not larger that that. +! if (sqrt(dx*dy) .le. 1000.) smixt(i,k)=min(sqrt(dx*dy),smixt(i,k)) if (qcl(i,kb) == 0 .and. qcl(i,k) > 0 .and. brunt(i,k) > 1.0d-4) then !If just above the cloud top and atmosphere is stable, set to 0.1 of local dz @@ -980,7 +979,7 @@ subroutine canuto() ! based on Canuto et at, 2001, JAS, 58, 1169-1172 (further referred to as C01) ! This allows to avoid having a prognostic equation for the third moment. ! Result is returned in a global variable w3 defined at the interface levels. - + ! Local variables integer i, k, kb, kc @@ -994,7 +993,7 @@ subroutine canuto() a2=0.5d0/c, a3=0.6d0/(c*(c-2.0d0)), a4=2.4d0/(3.0d0*c+5.0d0), & a5=0.6d0/(c*(3.0d0*c+5.0d0)) !Moorthi a5=0.6d0/(c*(3.0d0+5.0d0*c)) - + ! do k=1,nzm do k=2,nzm @@ -1147,16 +1146,16 @@ subroutine assumed_pdf() wqisb(k) = zero enddo - + DO k=1,nzm - + kd = k ku = k + 1 ! if (k == nzm) ku = k - + DO i=1,nx -! Initialize cloud variables to zero +! Initialize cloud variables to zero diag_qn = zero diag_frac = zero diag_ql = zero @@ -1172,8 +1171,8 @@ subroutine assumed_pdf() qw_first = total_water(i,k) ! w_first = half*(w(i,kd)+w(i,ku)) w_first = w(i,k) - - + + ! GET ALL INPUT VARIABLES ON THE SAME GRID ! Points to be computed with relation to thermo point ! Read in points that need to be averaged @@ -1218,7 +1217,7 @@ subroutine assumed_pdf() else sqrtqt = zero endif - + ! Find parameters of the double Gaussian PDF of vertical velocity @@ -1256,7 +1255,7 @@ subroutine assumed_pdf() onema = one - aterm sqrtw2t = sqrt(wrk) - + ! Eq. A.5-A.6 wrk = sqrt(onema/aterm) w1_1 = sqrtw2t * wrk @@ -1266,7 +1265,7 @@ subroutine assumed_pdf() w2_2 = w2_2 * w_sec(i,k) ENDIF - + ! Find parameters of the PDF of liquid/ice static energy ! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thlsec=',thlsec,' w1_2=',w1_2,' w1_1=',w1_1,& @@ -1284,7 +1283,7 @@ subroutine assumed_pdf() thl1_1 = -corrtest1 / w1_2 ! A.7 thl1_2 = -corrtest1 / w1_1 ! A.8 - + wrk1 = thl1_1 * thl1_1 wrk2 = thl1_2 * thl1_2 wrk3 = three * (one - aterm*wrk1 - onema*wrk2) @@ -1330,7 +1329,7 @@ subroutine assumed_pdf() qw1_2 = - corrtest2 / w1_1 ! A.8 tsign = abs(qw1_2-qw1_1) - + ! Skew_qw = skew_facw*Skew_w IF (tsign > 0.4) THEN @@ -1422,9 +1421,9 @@ subroutine assumed_pdf() ! Are the two plumes equal? If so then set qs and beta ! in each column to each other to save computation IF (Tl1_1 == Tl1_2) THEN - qs2 = qs1 + qs2 = qs1 beta2 = beta1 - ELSE + ELSE IF (Tl1_2 >= tbgmax) THEN lstarn2 = lcond esval = min(fpvsl(Tl1_2), pval) @@ -1441,14 +1440,14 @@ subroutine assumed_pdf() qs2 = om2 * eps * esval / (pval-0.378d0*esval) & + (one-om2) * epss * esval2 / (pval-0.378d0*esval2) ENDIF - + ! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 ! beta2 = (lstarn2*lstarn2*onebrvcp) / (Tl1_2*Tl1_2) ! A.18 beta2 = lstarn2 / Tl1_2 beta2 = beta2 * beta2 * onebrvcp - + ENDIF qs1 = qs1 * rhc(i,k) @@ -1579,9 +1578,8 @@ subroutine assumed_pdf() ncpi(i,k) = max(diag_qi/(fourb3*pi*RI_cub*500.0d0), nmin) endif endif - - + ! Compute the liquid water flux wqls = aterm * ((w1_1-w_first)*ql1) + onema * ((w1_2-w_first)*ql2) wqis = aterm * ((w1_1-w_first)*qi1) + onema * ((w1_2-w_first)*qi2) @@ -1589,7 +1587,7 @@ subroutine assumed_pdf() ! Compute statistics for the fluxes so we don't have to save these variables wqlsb(k) = wqlsb(k) + wqls wqisb(k) = wqisb(k) + wqis - + ! diagnostic buoyancy flux. Includes effects from liquid water, ice ! condensate, liquid & ice precipitation ! wrk = epsv * basetemp diff --git a/gfsphysics/physics/gwdps.f b/gfsphysics/physics/gwdps.f index 18385d596..433c9101e 100644 --- a/gfsphysics/physics/gwdps.f +++ b/gfsphysics/physics/gwdps.f @@ -587,10 +587,10 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! do i=1,npt iwklm(i) = 2 - IDXZB(i) = 0 + IDXZB(i) = 0 ! kreflm(i) = 0 enddo -! if (lprnt) +! if (lprnt) ! & print *,' in gwdps_lm.f npt,IM,IX,IY,km,me=',npt,IM,IX,IY,km,me ! ! @@ -680,7 +680,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & BNV2bar(I) = (PRSI(J,1)-PRSL(J,1)) * DELKS(I) * BNV2LM(I,1) ENDDO -! --- find the dividing stream line height +! --- find the dividing stream line height ! --- starting from the level above the max mtn downward ! --- iwklm(i) is the k-index of mtn elvmax elevation !> - Find the dividing streamline height starting from the level above @@ -698,14 +698,14 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! --- make averages, guess dividing stream (DS) line layer. ! --- This is not used in the first cut except for testing and ! --- is the vert ave of quantities from the surface to mtn top. -! +! DO I = 1, npt DO K = 1, iwklm(i)-1 J = ipt(i) RDELKS = DEL(J,K) * DELKS(I) - UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below - VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below - ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below + UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below + VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below + ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below if (k < iwklm(I)-1) then RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS(I) else @@ -718,7 +718,7 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & ! print *,' in gwdps_lm.f 5 =',i,kreflm(npt),BNV2bar(npt),me ! ! --- integrate to get PE in the trial layer. -! --- Need the first layer where PE>EK - as soon as +! --- Need the first layer where PE>EK - as soon as ! --- IDXZB is not 0 we have a hit and Zb is found. ! DO I = 1, npt @@ -976,13 +976,13 @@ SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & enddo enddo ! -!> - Calculate the reference level index: kref=max(2,KPBL+1). where +!> - Calculate the reference level index: kref=max(2,KPBL+1). where !! KPBL is the index for the PBL top layer. KBPS = 1 KMPS = KM DO I=1,npt J = ipt(i) - kref(I) = MAX(IWK(I), KPBL(J)+1 ) ! reference level + kref(I) = MAX(IWK(I), KPBL(J)+1 ) ! reference level DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,kref(I))) ! DELKS1(I) = 1.0 / (PRSI(J,1) - PRSL(J,kref(I))) UBAR (I) = 0.0 diff --git a/gfsphysics/physics/sfc_nst.f b/gfsphysics/physics/sfc_nst.f index 68b9b0982..51694d6cc 100644 --- a/gfsphysics/physics/sfc_nst.f +++ b/gfsphysics/physics/sfc_nst.f @@ -210,7 +210,7 @@ subroutine sfc_nst & ! integer :: k,i ! - real (kind=kind_phys), dimension(im) :: q0, qss, rch, + real (kind=kind_phys), dimension(im) :: q0, qss, rch, & rho_a, theta1, tv1, wndmag real(kind=kind_phys) elocp,tem @@ -218,7 +218,7 @@ subroutine sfc_nst & ! nstm related prognostic fields ! logical flag(im) - real (kind=kind_phys), dimension(im) :: + real (kind=kind_phys), dimension(im) :: & xt_old, xs_old, xu_old, xv_old, xz_old,zm_old,xtts_old, & xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old diff --git a/gfsphysics/physics/sfc_sice.f b/gfsphysics/physics/sfc_sice.f index 84fe55061..72addd6f1 100644 --- a/gfsphysics/physics/sfc_sice.f +++ b/gfsphysics/physics/sfc_sice.f @@ -171,7 +171,7 @@ subroutine sfc_sice & integer :: i, k - + logical :: flag(im) ! !===> ... begin here diff --git a/gfsphysics/physics/ugwp_driver_v0.f b/gfsphysics/physics/ugwp_driver_v0.f index 804bbac19..cfc5505b1 100644 --- a/gfsphysics/physics/ugwp_driver_v0.f +++ b/gfsphysics/physics/ugwp_driver_v0.f @@ -4,11 +4,11 @@ module sso_coorde ! specific to COORDE-2019 project OGW switches/sensitivity ! to diagnose SSO effects pgwd=1 (OGW is on) =0 (off) ! pgd4=4 (4 timse taub, control pgwd=1) -! +! use machine, only: kind_phys real(kind=kind_phys),parameter :: pgwd = 1._kind_phys real(kind=kind_phys),parameter :: pgwd4 = 1._kind_phys - end module sso_coorde + end module sso_coorde ! ! subroutine cires_ugwp_driver_v0(me, master, @@ -16,7 +16,7 @@ subroutine cires_ugwp_driver_v0(me, master, & cdmbgwd, xlat, xlatd, sinlat, coslat, spgrid, & ugrs, vgrs, tgrs, qgrs, prsi, prsl, prslk, & phii, phil, del, hprime, oc, oa4, clx, theta, - & gamm, sigma, elvmax, sgh30, kpbl, + & gamm, sigma, elvmax, sgh30, kpbl, & dusfcg, dvsfcg, gw_dudt, gw_dvdt, gw_dtdt, gw_kdis, & tau_tofd, tau_mtb, tau_ogw, tau_ngw, & zmtb, zlwb, zogw, du3dt_mtb,du3dt_ogw, du3dt_tms,rdxzb, @@ -26,15 +26,15 @@ subroutine cires_ugwp_driver_v0(me, master, ! Part 2 non-stationary multi-wave GWs FV3GFS-v0 ! Part 3 Dissipative version of UGWP-tendency application ! (similar to WAM-2017) -!----------------------------------------------------------- +!----------------------------------------------------------- use machine, only : kind_phys use physcons, only : con_cp, con_g, con_rd, con_rv - + use ugwp_wmsdis_init, only : tamp_mpa, ilaunch use sso_coorde, only : pgwd, pgwd4 implicit none !input - + integer, intent(in) :: me, master integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr @@ -79,7 +79,7 @@ subroutine cires_ugwp_driver_v0(me, master, ! real(kind=kind_phys), dimension(im) :: hprime, ! & oc, theta, sigma, gamm, elvmax ! real(kind=kind_phys), dimension(im, 4) :: clx, oa4 -! +! ! switches that activate impact of OGWs and NGWs along with eddy diffusion ! real(kind=kind_phys), parameter :: pogw=1.0, pngw=1.0, pked=1.0 @@ -96,14 +96,14 @@ subroutine cires_ugwp_driver_v0(me, master, write(6,*) ' COORDE EXPER pgwd4 = ', pgwd4 print * endif - + do i=1,im zlwb(i) = 0. enddo ! ! 1) ORO stationary GWs ! ------------------ - + if (do_ugwp .and. nmtvr == 14) then ! calling revised old GFS gravity wave drag CALL GWDPS_V0(IM, levs, imx, do_tofd, & Pdvdt, Pdudt, Pdtdt, Pkdis, @@ -120,7 +120,7 @@ subroutine cires_ugwp_driver_v0(me, master, print * write(6,*) 'FV3GFS finished gwdps_v0 in ugwp_driver_v0 ' print * - endif + endif else ! calling old GFS gravity wave drag as is do k=1,levs do i=1,im @@ -147,11 +147,11 @@ subroutine cires_ugwp_driver_v0(me, master, if (cdmbgwd(3) > 0.0) then ! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing ! ---------------------------------------------- -!-------- +!-------- ! GMAO GEOS-5/MERRA GW-forcing lat-dep !-------- call slat_geos5_tamp(im, tamp_mpa, xlatd, tau_ngw) - + ! call slat_geos5(im, xlatd, tau_ngw) ! if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then @@ -184,7 +184,7 @@ subroutine cires_ugwp_driver_v0(me, master, ! call fv3_ugwp_solv2_v0(im, levs, dtp, & tgrs, ugrs, vgrs, qgrs, prsl, prsi, - & phil, xlatd, sinlat, coslat, + & phil, xlatd, sinlat, coslat, & gw_dudt, gw_dvdt, gw_dTdt, gw_kdis, & tau_ngw, me, master, kdt) @@ -250,11 +250,11 @@ subroutine cires_ugwp_driver_v0(me, master, enddo end subroutine cires_ugwp_driver_v0 -! -!===================================================================== ! -!ugwp-v0 subroutines: GWDPS_V0 and fv3_ugwp_solv2_v0 -! +!===================================================================== +! +!ugwp-v0 subroutines: GWDPS_V0 and fv3_ugwp_solv2_v0 +! !===================================================================== SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, & Pdvdt, Pdudt, Pdtdt, Pkdis, U1,V1,T1,Q1,KPBL, @@ -300,7 +300,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, integer, intent(in) :: KPBL(IM) ! Index for the PBL top layer! real(kind=kind_phys), intent(in) :: dtp ! time step real(kind=kind_phys), intent(in) :: cdmbgwd(2) - + real(kind=kind_phys), intent(in), dimension(im,km) :: & u1, v1, t1, q1, & del, prsl, prslk, phil @@ -314,20 +314,20 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, real(kind=kind_phys), intent(in) :: ELVMAXD(IM), THETA(IM) real(kind=kind_phys), intent(in) :: vSIGMA(IM), vGAMMA(IM) real(kind=kind_phys) :: SIGMA(IM), GAMMA(IM) - + !output -phys-tend real(kind=kind_phys),dimension(im,km),intent(out) :: & Pdvdt, Pdudt, Pkdis, Pdtdt ! output - diag-coorde &, dudt_mtb, dudt_ogw, dudt_tms -! +! real(kind=kind_phys),dimension(im) :: RDXZB, zmtb, zogw &, tau_ogw, tau_mtb, tau_tofd &, dusfc, dvsfc ! !--------------------------------------------------------------------- ! # of permissible sub-grid orography hills for "any" resolution < 25 -! correction for "elliptical" hills based on shilmin-area =sgrid/25 +! correction for "elliptical" hills based on shilmin-area =sgrid/25 ! 4.*gamma*b_ell*b_ell >= shilmin ! give us limits on [b_ell & gamma *b_ell] > 5 km =sso_min ! gamma_min = 1/4*shilmin/sso_min/sso_min @@ -345,21 +345,21 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, real(kind=kind_phys) :: belpmin, dsmin, dsmax ! real(kind=kind_phys) :: arhills(im) ! not used why do we need? real(kind=kind_phys) :: xlingfs - -! -! locals + +! +! locals ! mean flow real(kind=kind_phys), dimension(im,km) :: RI_N, BNV2, RO &, VTK, VTJ, VELCO -!mtb +!mtb real(kind=kind_phys), dimension(im) :: OA, CLX , elvmax, wk &, PE, EK, UP - + real(kind=kind_phys), dimension(im,km) :: DB, ANG, UDS real(kind=kind_phys) :: ZLEN, DBTMP, R, PHIANG, DBIM, ZR real(kind=kind_phys) :: ENG0, ENG1, COSANG2, SINANG2 - real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem + real(kind=kind_phys) :: bgam, cgam, gam2, rnom, rdem ! ! TOFD ! Some constants now in "use ugwp_oro_init" + "use ugwp_common" @@ -370,7 +370,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, &, epstofd1, krf_tofd1 &, up1, vp1, zpm real(kind=kind_phys),dimension(im, km) :: axtms, aytms -! +! ! OGW ! LOGICAL ICRILV(IM) @@ -381,9 +381,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, real(kind=kind_phys) :: TAUP(IM,km+1), TAUD(IM,km) real(kind=kind_phys) :: taub(im), taulin(im), heff, hsat, hdis - integer, dimension(im) :: kref, idxzb, ipt, kreflm, + integer, dimension(im) :: kref, idxzb, ipt, kreflm, & iwklm, iwk, izlow -! +! !check what we need ! real(kind=kind_phys) :: bnv, fr, ri_gw @@ -397,7 +397,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, &, cdmb4, mtbridge &, kxridge, inv_b2eff, zw1, zw2 &, belps, aelps, nhills, selps - + integer :: kmm1, kmm2, lcap, lcapp1 &, npt, kbps, kbpsp1,kbpsm1 &, kmps, idir, nwd, klcap, kp1, kmpbl, kmll @@ -407,7 +407,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, grav2 = grav + grav ! ! mtb-blocking sigma_min and dxres => cires_initialize -! +! sgrmax = maxval(sparea) ; sgrmin = minval(sparea) dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) @@ -442,9 +442,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, idxzb(i) = 0 zmtb(i) = 0.0 zogw(i) = 0.0 - rdxzb(i) = 0.0 + rdxzb(i) = 0.0 tau_ogw(i) = 0.0 - tau_mtb(i) = 0.0 + tau_mtb(i) = 0.0 dusfc(i) = 0.0 dvsfc(i) = 0.0 tau_tofd(i) = 0.0 @@ -465,13 +465,13 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, dudt_tms(i,k) = 0.0 enddo enddo - + ! ---- for lm and gwd calculation points - + npt = 0 do i = 1,im if ( elvmaxd(i) >= hminmt .and. hprime(i) >= hpmin ) then - + npt = npt + 1 ipt(npt) = i ! arhills(i) = 1.0 @@ -486,7 +486,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! small-scale "turbulent" oro-scales < sso_min ! if( aelps < sso_min .and. do_adjoro) then - + ! a, b > sso_min upscale ellipse a/b > 0.1 a>sso_min & h/b=>new_sigm ! aelps = sso_min @@ -504,38 +504,38 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, nhills = min(nhilmax, sparea(i)/selps) ! arhills(i) = max(nhills, 1.0) -!333 format( ' nhil: ', I6, 4(2x, F9.3), 2(2x, E9.3)) +!333 format( ' nhil: ', I6, 4(2x, F9.3), 2(2x, E9.3)) ! if (kdt==1 ) ! & write(6,333) nint(nhills)+1,xlatd(i), hprime(i),aelps*1.e-3, ! & belps*1.e-3, sigma(i),gamma(i) endif enddo - + IF (npt == 0) then ! print *, 'oro-npt = 0 elvmax ', maxval(elvmaxd), hminmt -! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin +! print *, 'oro-npt = 0 hprime ', maxval(hprime), hpmin RETURN ! No gwd/mb calculation done endif do i=1,npt iwklm(i) = 2 - IDXZB(i) = 0 + IDXZB(i) = 0 kreflm(i) = 0 enddo - + do k=1,km do i=1,im db(i,k) = 0.0 ang(i,k) = 0.0 - uds(i,k) = 0.0 + uds(i,k) = 0.0 enddo enddo KMM1 = km - 1 ; KMM2 = km - 2 ; KMLL = kmm1 - LCAP = km ; LCAPP1 = LCAP + 1 - + LCAP = km ; LCAPP1 = LCAP + 1 + DO I = 1, npt j = ipt(i) ELVMAX(J) = min (ELVMAXd(J)*0. + sigfac * hprime(j), hncrit) @@ -546,11 +546,11 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, DO I = 1, npt j = ipt(i) ztopH = sigfac * hprime(j) - zlowH = sigfacs* hprime(j) + zlowH = sigfacs* hprime(j) pkp1log = phil(j,k+1) * rgrav pklog = phil(j,k) * rgrav ! if (( ELVMAX(j) <= pkp1log) .and. (ELVMAX(j).ge.pklog) ) -! & iwklm(I) = MAX(iwklm(I), k+1 ) +! & iwklm(I) = MAX(iwklm(I), k+1 ) if (( ztopH <= pkp1log) .and. (zTOPH >= pklog) ) & iwklm(I) = MAX(iwklm(I), k+1 ) ! @@ -586,18 +586,18 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, BVF2 = grav2 * RDZ * (VTK(I,K+1)-VTK(I,K)) & / (VTK(I,K+1)+VTK(I,K)) bnv2(i,k+1) = max( BVF2, bnv2min ) - RI_N(I,K+1) = Bnv2(i,k)/SHR2 ! Richardson number consistent with BNV2 + RI_N(I,K+1) = Bnv2(i,k)/SHR2 ! Richardson number consistent with BNV2 ! ! add here computation for Ktur and OGW-dissipation fro VE-GFS -! +! ENDDO ENDDO K = 1 DO I = 1, npt bnv2(i,k) = bnv2(i,k+1) ENDDO -! -! level iwklm =>phil(j,k)/g < sigfac * hprime(j) < phil(j,k+1)/g +! +! level iwklm =>phil(j,k)/g < sigfac * hprime(j) < phil(j,k+1)/g ! DO I = 1, npt J = ipt(i) @@ -610,19 +610,19 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ROLL (I) = 0.0 PE (I) = 0.0 EK (I) = 0.0 - BNV2bar(I) = 0.0 + BNV2bar(I) = 0.0 ENDDO ! DO I = 1, npt k_zlow = izlow(I) if (k_zlow == iwklm(i)) k_zlow = 1 - DO K = k_zlow, iwklm(I)-1 ! Kreflm(I)= iwklm(I)-1 + DO K = k_zlow, iwklm(I)-1 ! Kreflm(I)= iwklm(I)-1 J = ipt(i) ! laye-aver Rho, U, V RDELKS = DEL(J,K) * DELKS(I) - UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below - VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below - ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below -! + UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below + VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below + ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below +! BNV2bar(I) = BNV2bar(I) + .5*(BNV2(I,K)+BNV2(I,K+1))* RDELKS ENDDO ENDDO @@ -632,24 +632,24 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! ! integrate from Ztoph = sigfac*hprime down to Zblk if exists ! find ph_blk, dz_blk like in LM-97 and IFS -! - ph_blk =0. +! + ph_blk = 0. DO K = iwklm(I), 1, -1 PHIANG = atan2(V1(J,K),U1(J,K))*RAD_TO_DEG ANG(I,K) = ( THETA(J) - PHIANG ) if ( ANG(I,K) > 90. ) ANG(I,K) = ANG(I,K) - 180. if ( ANG(I,K) < -90. ) ANG(I,K) = ANG(I,K) + 180. ANG(I,K) = ANG(I,K) * DEG_TO_RAD - UDS(I,K) = + UDS(I,K) = & MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), velmin) ! IF (IDXZB(I) == 0 ) then dz_blk = ( PHII(J,K+1) - PHII(J,K) ) *rgrav - PE(I) = PE(I) + BNV2(I,K) * + PE(I) = PE(I) + BNV2(I,K) * & ( ELVMAX(J) - phil(J,K)*rgrav ) * dz_blk - UP(I) = max(UDS(I,K) * cos(ANG(I,K)), velmin) - EK(I) = 0.5 * UP(I) * UP(I) + UP(I) = max(UDS(I,K) * cos(ANG(I,K)), velmin) + EK(I) = 0.5 * UP(I) * UP(I) ph_blk = ph_blk + dz_blk*sqrt(BNV2(I,K))/UP(I) @@ -665,7 +665,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ENDDO ! ! Alternative expression: ZMTB = max(Heff*(1. -Fcrit_gfs/Fr), 0) -! fcrit_gfs/fr +! fcrit_gfs/fr ! goto 788 @@ -676,7 +676,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, Fr = heff*bnv/Ulow(i) ZW1 = max(Heff*(1. -fcrit_gfs/fr), 0.0) zw2 = phil(j,2)*rgrav - if (Fr > fcrit_gfs .and. zw1 > zw2 ) then + if (Fr > fcrit_gfs .and. zw1 > zw2 ) then do k=2, kmm1 pkp1log = phil(j,k+1) * rgrav pklog = phil(j,k) * rgrav @@ -693,54 +693,54 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! ! --- The drag for mtn blocked flow -! +! cdmb4 = 0.25*cdmb DO I = 1, npt J = ipt(i) ! IF ( IDXZB(I) > 0 ) then -! (4.16)-IFS +! (4.16)-IFS gam2 = gamma(j)*gamma(j) BGAM = 1.0 - 0.18*gamma(j) - 0.04*gam2 CGAM = 0.48*gamma(j) + 0.30*gam2 DO K = IDXZB(I)-1, 1, -1 - ZLEN = SQRT( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / + ZLEN = SQRT( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / & ( PHIL(J,K ) + Grav * hprime(J) ) ) tem = cos(ANG(I,K)) COSANG2 = tem * tem - SINANG2 = 1.0 - COSANG2 + SINANG2 = 1.0 - COSANG2 ! -! cos =1 sin =0 => 1/R= gam ZR = 2.-gam +! cos =1 sin =0 => 1/R= gam ZR = 2.- gam ! cos =0 sin =1 => 1/R= 1/gam ZR = 2.- 1/gam ! rdem = COSANG2 + GAM2 * SINANG2 rnom = COSANG2*GAM2 + SINANG2 -! +! ! metOffice Dec 2010 ! correction of H. Wells & A. Zadra for the ! aspect ratio of the hill seen by MF ! (1/R , R-inverse below: 2-R) - rdem = max(rdem, 1.e-6) + rdem = max(rdem, 1.e-6) R = sqrt(rnom/rdem) ZR = MAX( 2. - R, 0. ) sigres = max(sigmin, sigma(J)) if (hprime(J)/sigres > dxres) sigres = hprime(J)/dxres mtbridge = ZR * sigres*ZLEN / hprime(J) -! (4.15)-IFS +! (4.15)-IFS ! DBTMP = CDmb4 * mtbridge * ! & MAX(cos(ANG(I,K)), gamma(J)*sin(ANG(I,K))) ! (4.16)-IFS DBTMP = CDmb4*mtbridge*(bgam* COSANG2 +cgam* SINANG2) DB(I,K)= DBTMP * UDS(I,K) ENDDO -! +! endif ENDDO -! +! !............................. !............................. ! end mtn blocking section @@ -748,7 +748,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, !............................. ! !--- Orographic Gravity Wave Drag Section -! +! ! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 ! inside "cires_ugwp_initialize.F90" now ! @@ -757,18 +757,18 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! ! METO-scheme: ! k_mtb = max(k_zmtb, k_n*hprime/2] to reduce diurnal variations taub_ogw -! +! DO K=3,KMPBL DO I=1,npt j = ipt(i) tem = (prsi(j,1) - prsi(j,k)) if (tem < dpmin) iwk(i) = k ! dpmin=50 mb -!=============================================================== +!=============================================================== ! lev=111 t=311.749 hkm=0.430522 Ps-P(iwk)=52.8958 ! below "Hprime" - source of OGWs and below Zblk !!! ! 27 2 kpbl ~ 1-2 km < Hprime -!=============================================================== +!=============================================================== enddo enddo ! @@ -845,7 +845,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! !------------------ ! v0: incorporates latest modifications for kxridge and heff/hsat -! and taulin for Fr <=fcrit_gfs +! and taulin for Fr <=fcrit_gfs ! and concept of "clipped" hill if zmtb > 0. to make ! the integrated "tau_sso = tau_ogw +tau_mtb" close to reanalysis data ! it is still used the "single-OGWave"-approach along ULOW-upwind @@ -984,10 +984,10 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ENDIF ENDDO ENDDO -! +! ! zero momentum deposition at the top model layer -! - taup(1:npt,km+1) = taup(1:npt,km) +! + taup(1:npt,km+1) = taup(1:npt,km) ! ! Calculate wave acc-n: - (grav)*d(tau)/d(p) = taud ! @@ -998,11 +998,11 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ENDDO ! !------scale MOMENTUM DEPOSITION AT TOP TO 1/2 VALUE -! it is zero now +! it is zero now ! DO I = 1,npt ! TAUD(I, km) = TAUD(I,km) * FACTOP ! ENDDO - + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ !------IF THE GRAVITY WAVE DRAG WOULD FORCE A CRITICAL LINE IN THE !------LAYERS BELOW SIGMA=RLOLEV DURING THE NEXT DELTIM TIMESTEP, @@ -1027,23 +1027,23 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! !--------------------------- OROGW-solver of GFS PSS-1986 ! - else + else ! !--------------------------- OROGW-solver of WAM2017 ! ! sigres = max(sigmin, sigma(J)) ! if (heff/sigres.gt.dxres) sigres=heff/dxres -! inv_b2eff = 0.5*sigres/heff -! XLINV(I) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./Lridge +! inv_b2eff = 0.5*sigres/heff +! XLINV(I) = max(kxridge, inv_b2eff) ! 0.5*sigma(j)/heff = 1./Lridge dtfac(:) = 1.0 - + call oro_wam_2017(im, km, npt, ipt, kref, kdt, me, master, & dtp, dxres, taub, u1, v1, t1, xn, yn, bnv2, ro, prsi,prsL, & del, sigma, hprime, gamma, theta, & sinlat, xlatd, taup, taud, pkdis) - + endif ! oro_wam_2017 - LINSATDIS-solver of WAM-2017 -! +! !--------------------------- OROGW-solver of WAM2017 ! ! TOFD as in BELJAARS-2004 @@ -1054,42 +1054,42 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, if ( kdt == 1 .and. me == 0) then print *, 'VAY do_tofd from surface to ', ztop_tofd endif - DO I = 1,npt + DO I = 1,npt J = ipt(i) zpbl =rgrav*phil( j, kpbl(j) ) - + sigflt = min(sgh30(j), 0.3*hprime(j)) ! cannot exceed 30% of LS-SSO - + zsurf = phii(j,1)*rgrav do k=1,km zpm(k) = phiL(j,k)*rgrav up1(k) = u1(j,k) vp1(k) = v1(j,k) enddo - - call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, + + call ugwp_tofd1d(km, sigflt, elvmaxd(j), zsurf, zpbl, & up1, vp1, zpm, utofd1, vtofd1, epstofd1, krf_tofd1) - + do k=1,km axtms(j,k) = utofd1(k) aytms(j,k) = vtofd1(k) -! +! ! add TOFD to GW-tendencies -! +! pdvdt(J,k) = pdvdt(J,k) + aytms(j,k) pdudt(J,k) = pdudt(J,k) + axtms(j,k) enddo !2018-diag tau_tofd(J) = sum( utofd1(1:km)* del(j,1:km)) enddo - ENDIF ! do_tofd + ENDIF ! do_tofd !--------------------------- ! combine oro-drag effects -!--------------------------- +!--------------------------- ! + diag-3d - dudt_tms = axtms + dudt_tms = axtms tau_ogw = 0. tau_mtb = 0. @@ -1234,8 +1234,8 @@ end subroutine gwdps_v0 ! next will be lsatdis for both fv3wam & fv3gfs-128l implementations ! with (a) stochastic-deterministic propagation solvers for wave packets/spectra ! (b) gw-sources: oro/convection/dyn-instability (fronts/jets/pv-anomalies) -! (c) guidance from high-res runs for GW sources and res-aware tune-ups -!23456 +! (c) guidance from high-res runs for GW sources and res-aware tune-ups +!23456 ! ! call gwdrag_wam(1, im, ix, km, ksrc, dtp, ! & xlat, gw_dudt, gw_dvdt, taux, tauy) @@ -1260,8 +1260,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! nov 2015 alternative gw-solver for nggps-wam ! nov 2017 nh/rotational gw-modes for nh-fv3gfs ! --------------------------------------------------------------------------------- -! - +! + use ugwp_common , only : rgrav, grav, cpd, rd, rv &, omega2, rcpd2, pi, pi2, fv &, rad_to_deg, deg_to_rad @@ -1275,15 +1275,15 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, &, zci, zdci, zci4, zci3, zci2 &, zaz_fct, zcosang, zsinang &, nwav, nazd, zcimin, zcimax -! +! implicit none !23456 - + integer, intent(in) :: klev ! vertical level integer, intent(in) :: klon ! horiz tiles - real, intent(in) :: dtime ! model time step - real, intent(in) :: vm1(klon,klev) ! meridional wind + real, intent(in) :: dtime ! model time step + real, intent(in) :: vm1(klon,klev) ! meridional wind real, intent(in) :: um1(klon,klev) ! zonal wind real, intent(in) :: qm1(klon,klev) ! spec. humidity real, intent(in) :: tm1(klon,klev) ! kin temperature @@ -1304,19 +1304,19 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, real, intent(out) :: pdudt(klon,klev) ! zonal momentum tendency real, intent(out) :: pdvdt(klon,klev) ! meridional momentum tendency real, intent(out) :: pdtdt(klon,klev) ! gw-heating (u*ax+v*ay)/cp - real, intent(out) :: dked(klon,klev) ! gw-eddy diffusion - real, parameter :: minvel = 0.5 ! - real, parameter :: epsln = 1.0d-12 ! - + real, intent(out) :: dked(klon,klev) ! gw-eddy diffusion + real, parameter :: minvel = 0.5 ! + real, parameter :: epsln = 1.0d-12 ! + !vay-2018 real :: taux(klon,klev+1) ! EW component of vertical momentum flux (pa) real :: tauy(klon,klev+1) ! NS component of vertical momentum flux (pa) - real :: phil(klon,klev) ! gphil/grav + real :: phil(klon,klev) ! gphil/grav ! ! local =============================================================================================== ! - + ! real :: zthm1(klon,klev) ! temperature interface levels real :: zthm1 ! 1.0 / temperature interface levels real :: zbvfhm1(klon,ilaunch:klev) ! interface BV-frequency @@ -1326,7 +1326,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, real :: zvhm1(klon,ilaunch:klev) ! meridional wind real :: v_zmet(klon,ilaunch:klev) real :: vueff(klon,ilaunch:klev) - real :: zbvfl(klon) ! BV at launch level + real :: zbvfl(klon) ! BV at launch level real :: c2f2(klon) !23456 @@ -1357,7 +1357,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, real :: zcin2, zbvfl2, zcin3, zbvfl3, zcinc real :: zatmp, zfluxs, zdep, zfluxsq, zulm, zdft, ze1, ze2 -! +! real :: zdelp,zrgpts real :: zthstd,zrhostd,zbvfstd real :: tvc1, tvm1, tem1, tem2, tem3 @@ -1369,13 +1369,13 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, real, parameter :: rcpdl = cpd/grav ! 1/[g/cp] == cp/g &, grav2cpd = grav/rcpdl ! g*(g/cp)= g^2/cp &, cpdi = 1.0d0/cpd - + real :: expdis, fdis ! real :: fmode, expdis, fdis real :: v_kzi, v_kzw, v_cdp, v_wdp, sc, tx1 integer :: j, k, inc, jk, jl, iazi -! +! !-------------------------------------------------------------------------- ! do k=1,klev @@ -1387,16 +1387,16 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, phil(j,k) = philg(j,k) * rgrav enddo enddo -!----------------------------------------------------------- +!----------------------------------------------------------- ! also other options to alter tropical values ! tamp = 100.e-3*1.e3 = 100 mpa -! vay-2017 zfluxglob=> lat-dep here from geos-5/merra-2 +! vay-2017 zfluxglob=> lat-dep here from geos-5/merra-2 !----------------------------------------------------------- -! call slat_geos5_tamp(klon, tamp_mpa, xlatd, tau_ngw) +! call slat_geos5_tamp(klon, tamp_mpa, xlatd, tau_ngw) - -! phil = philg*rgrav +! phil = philg*rgrav + ! rcpd = 1.0/(grav/cpd) ! 1/[g/cp] ! grav2cpd = grav*grav/cpd ! g*(g/cp)= g^2/cp @@ -1418,7 +1418,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo enddo -! +! ! set initial min Cxi for critical level absorption do iazi=1,nazd do jl=1,klon @@ -1435,8 +1435,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, zthm1 = 2.0 / (tvc1+tvm1) zuhm1(jl,jk) = 0.5 *(um1(jl,jk-1)+um1(jl,jk)) zvhm1(jl,jk) = 0.5 *(vm1(jl,jk-1)+vm1(jl,jk)) -! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) - zrhohm1(jl,jk) = prsi(jl,jk)*rdi*zthm1 ! rho = p/(RTv) +! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) + zrhohm1(jl,jk) = prsi(jl,jk)*rdi*zthm1 ! rho = p/(RTv) zdelp = phil(jl,jk)-phil(jl,jk-1) !>0 ...... dz-meters v_zmet(jl,jk) = zdelp + zdelp delpi(jl,jk) = grav / (prsi(jl,jk-1) - prsi(jl,jk)) @@ -1447,7 +1447,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, zbn2(jl,jk) = grav2cpd*zthm1 & * (1.0+rcpdl*(tm1(jl,jk)-tm1(jl,jk-1))/zdelp) zbn2(jl,jk) = max(min(zbn2(jl,jk), gssec), bv2min) - zbvfhm1(jl,jk) = sqrt(zbn2(jl,jk)) ! bn = sqrt(bn2) + zbvfhm1(jl,jk) = sqrt(zbn2(jl,jk)) ! bn = sqrt(bn2) enddo enddo @@ -1470,7 +1470,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo ! ! define intrinsic velocity (relative to launch level velocity) u(z)-u(zo), and coefficinets -! ------------------------------------------------------------------------------------------ +! ------------------------------------------------------------------------------------------ do iazi=1, nazd do jl=1,klon zul(jl,iazi) = zcosang(iazi) * zuhm1(jl,ilaunch) @@ -1604,7 +1604,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo enddo -! ------------------------------------------------------------- +! ------------------------------------------------------------- ! azimuth do-loop ! -------------------- do iazi=1, nazd @@ -1671,8 +1671,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, !======================================================================= ! saturated limit wfit = kzw*kzw*kt; wfdt = wfit/(kxw*cx)*betat ! & dissipative kzi = 2.*kzw*(wfdm+wfdt)*dzpi(k) -! define kxw = -!======================================================================= +! define kxw = +!======================================================================= v_cdp = abs(zcin-zui(jL,jk,iazi)) v_wdp = v_kxw*v_cdp wdop2 = v_wdp* v_wdp @@ -1700,7 +1700,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, v_kzw = 0. v_cdp = 0. ! no effects of reflected waves endif - + ! fmode = zflux(jl,inc,iazi) ! fdis = fmode*expdis fdis = expdis * zflux(jl,inc,iazi) @@ -1709,10 +1709,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! linsatdis = 1.0 , here: u'^2 ~ linsatdis* [v_cdp*v_cdp] ! zfluxs = zfct(jl,jk)*v_cdp*v_cdp*zcinc -! +! ! zfluxs= zfct(jl,jk)*(zcin-zui(jl,jk,iazi))**2/zcin ! flux_tot - sat.flux -! +! zdep = zact(jl,inc,iazi)* (fdis-zfluxs) if(zdep > 0.0 ) then ! subs on sat-limit @@ -1735,7 +1735,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, do jl=1,klon vc_zflx_mode = zact(jl,inc,iazi)*zflux(jl,inc,iazi) zpu(jl,jk,iazi) = zpu(jl,jk,iazi) + vc_zflx_mode*zcinc - + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check monotonic decrease ! (heat deposition integration over spectral mode for each azimuth @@ -1754,25 +1754,25 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! ! endif - enddo !jl=1,klon + enddo !jl=1,klon enddo !waves inc=1,nwav ! -------------- enddo ! end jk do-loop vertical loop ! --------------- enddo ! end nazd do-loop -! ---------------------------------------------------------------------------- +! ---------------------------------------------------------------------------- ! sum contribution for total zonal and meridional flux + ! energy dissipation ! --------------------------------------------------- -! +! do jk=1,klev+1 do jl=1,klon - taux(jl,jk) = 0.0 - tauy(jl,jk) = 0.0 + taux(jl,jk) = 0.0 + tauy(jl,jk) = 0.0 enddo - enddo - + enddo + tem3 = zaz_fct*cpdi do iazi=1,nazd tem1 = zaz_fct*zcosang(iazi) @@ -1788,7 +1788,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, enddo ! ! update du/dt and dv/dt tendencies ..... no contribution to heating => keddy/tracer-mom-heat -! ---------------------------- +! ---------------------------- ! do jk=ilaunch,klev @@ -1799,7 +1799,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ze2 = (tauy(jl,jk)-tauy(jl,jk-1))*zdelp if (abs(ze1) >= maxdudt ) then ze1 = sign(maxdudt, ze1) - endif + endif if (abs(ze2) >= maxdudt ) then ze2 = sign(maxdudt, ze2) endif @@ -1814,9 +1814,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! if (dked(jl,jk) < 0) dked(jl,jk) = dked_min enddo enddo -! +! ! add limiters/efficiency for "unbalanced ics" if it is needed -! +! do jk=ilaunch,klev do jl=1, klon pdudt(jl,jk) = gw_eff * pdudt(jl,jk) @@ -1879,7 +1879,7 @@ subroutine edmix_ugwp_v0(im, levs, dtp, ! locals ! integer :: i, j, k -!------------------------------------------------------------------------ +!------------------------------------------------------------------------ ! solving 1D-vertical eddy diffusion to "smooth" ! GW-related tendencies: du/dt, dv/dt, d(PT)/dt ! we need to use sum of molecular + eddy terms including turb-part @@ -1899,7 +1899,7 @@ subroutine edmix_ugwp_v0(im, levs, dtp, ! 1-st trial w/o PBL interactions: add dU, dV dT tendencies ! compute BV, SHR2, Ri => Kturb, Kturb + Kwave => Apply it to "X_Tend +X " ! ed_X = X_ed - X => final eddy tendencies -!--------------------------------------------------------------------------- +!--------------------------------------------------------------------------- ! rzs=30m dk = rzs*rzs*sqrt(shr2(i,k)) ! Ktemp = dk/(1+5.*ri)**2 Kmom = Pr*Ktemp ! @@ -1910,26 +1910,26 @@ subroutine edmix_ugwp_v0(im, levs, dtp, real(kind=kind_phys),dimension(levs) :: bn2, shr2, ksum real(kind=kind_phys) :: eps_shr, eps_bn2, eps_dis real(kind=kind_phys) :: rdz , uz, vz, ptz -! ------------------------------------------------------------------------- +! ------------------------------------------------------------------------- ! Prw*Lsat2 =1, for GW-eddy diffusion Pr_wave = Kv/Kt ! Pr_wave ~1/Lsat2 = 1/Frcit2 = 2. => Lsat2 = 1./2 (Frc ~0.7) -! m*u'/N = u'/{c-U) = h'N/(c-U) = Lsat = Fcrit +! m*u'/N = u'/{c-U) = h'N/(c-U) = Lsat = Fcrit ! > PBL: 0.25 < prnum = 1.0 + 2.1*ri < 4 ! monin-edmf parameter(rlam=30.0,vk=0.4,vk2=vk*vk) rlamun=150.0 ! real(kind=kind_phys), parameter :: iPr_pt = 0.5, dw2min = 1.e-4 - real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb + real(kind=kind_phys), parameter :: lturb = 30., sc2 = lturb*lturb real(kind=kind_phys), parameter :: ulturb=150.,sc2u=ulturb* ulturb real(kind=kind_phys), parameter :: ric =0.25 real(kind=kind_phys), parameter :: rimin = -10., prmin = 0.25 real(kind=kind_phys), parameter :: prmax = 4.0 real(kind=kind_phys), parameter :: hps = 7000., h4 = 0.25/hps real(kind=kind_phys), parameter :: kedmin = 0.01, kedmax = 250. - - + + real(kind=kind_phys) :: rdtp, rineg, kamp, zmet, zgrow real(kind=kind_phys) :: stab, stab_dt, dtstab, ritur - integer :: nstab + integer :: nstab real(kind=kind_phys) :: w1, w2, w3 rdtp = 1./dtp nstab = 1 @@ -1981,7 +1981,7 @@ subroutine edmix_ugwp_v0(im, levs, dtp, stab = 2.*ksum(k)*rdz*rdz*dtp if ( stab >= 1.0 ) then stab_dt = max(stab_dt, stab) - endif + endif enddo nstab = max(1, nint(stab_dt)+1) dtstab = dtp / float(nstab) @@ -1989,7 +1989,7 @@ subroutine edmix_ugwp_v0(im, levs, dtp, Fw(1:levs) = pdudt(i, 1:levs) Fw1(1:levs) = pdvdt(i, 1:levs) Km(1:levs) = ksum(1:levs) * rho(1:levs)* rho(1:levs) - + do j=1, nstab call diff_1d_wtend(levs, dtstab, Fw, Fw1, levs, & del(i,:), Sw, Sw1) @@ -1999,7 +1999,7 @@ subroutine edmix_ugwp_v0(im, levs, dtp, ed_dudt(i,:) = Sw ed_dvdt(i,:) = Sw1 - + Pt(1:levs) = t1(i,1:levs)*Ptmap(1:levs) Kpt = Km*iPr_pt Fw(1:levs) = pdTdt(i, 1:levs)*Ptmap(1:levs) @@ -2021,10 +2021,10 @@ subroutine diff_1d_wtend(levs, dt, F, F1, Km, rdp, rdpm, S, S1) real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) integer :: i, k - real(kind=kind_phys) :: Kp1, ad, cd, bd -! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd + real(kind=kind_phys) :: Kp1, ad, cd, bd +! real(kind=kind_phys) :: km1, Kp1, ad, cd, bd ! S(:) = 0.0 ; S1(:) = 0.0 -! +! ! explicit diffusion solver ! k = 1 diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 6017f5fa6..a73a19084 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1106,7 +1106,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) + Sfcprop(nb)%tsfco(ix) * tem enddo enddo - else ! in this case ice fracion is fraction of water fraction + else ! in this case ice fraction is fraction of water fraction do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) !--- specify tsfcl/zorll from existing variable tsfco/zorlo @@ -1114,15 +1114,16 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) - if (Sfcprop(nb)%slmsk(ix) < 0.1 .or. Sfcprop(nb)%slmsk(ix) > 1.9) then + if (abs(1.0-Sfcprop(nb)%slmsk(ix)) < 0.1) then + Sfcprop(nb)%landfrac(ix) = 1.0 ! land + Sfcprop(nb)%lakefrac(ix) = 0.0 + else Sfcprop(nb)%landfrac(ix) = 0.0 if (Sfcprop(nb)%oro_uf(ix) > 0.01) then Sfcprop(nb)%lakefrac(ix) = 1.0 ! lake else Sfcprop(nb)%lakefrac(ix) = 0.0 ! ocean endif - else - Sfcprop(nb)%landfrac(ix) = 1.0 ! land endif enddo enddo From 7ff47934ad5a8c412ab23fd3378f9b6ddd288efa Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 22 Oct 2019 18:13:51 +0000 Subject: [PATCH 02/91] some fixes to physics driver --- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 76c6590d6..d04bcae33 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -43,6 +43,7 @@ module module_physics_driver !--- CONSTANT PARAMETERS real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp + real(kind=kind_phys), parameter :: epsln = 1.0d-10 real(kind=kind_phys), parameter :: qmin = 1.0d-10 real(kind=kind_phys), parameter :: qsmall = 1.0d-20 real(kind=kind_phys), parameter :: rainmin = 1.0d-13 @@ -1108,7 +1109,7 @@ subroutine GFS_physics_driver & frland(i) = Sfcprop%landfrac(i) if (frland(i) > zero) dry(i) = .true. tem = one - frland(i) - if (tem > zero) then + if (tem > epsln) then if (flag_cice(i)) then if (fice(i) >= Model%min_seaice*tem) then icy(i) = .true. @@ -1123,7 +1124,7 @@ subroutine GFS_physics_driver & fice(i) = zero endif endif - if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) +! if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) else fice(i) = zero endif @@ -1133,7 +1134,7 @@ subroutine GFS_physics_driver & if (tem1 > zero) then wet(i) = .true. ! there is some open water! ! if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), tgice) - if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) +! if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) endif enddo else @@ -1154,7 +1155,7 @@ subroutine GFS_physics_driver & if (fice(i) < one) then wet(i) = .true. ! Sfcprop%tsfco(i) = tgice - Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) +! Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) ! Sfcprop%tsfco(i) = max((Sfcprop%tsfc(i) - fice(i)*sfcprop%tisfc(i)) & ! / (one - fice(i)), tgice) endif @@ -1740,7 +1741,7 @@ subroutine GFS_physics_driver & ! if (wet(i) .and. .not.icy(i)) then ! if (wet(i) .and. (Model%frac_grid .or. .not. icy(i))) then if (wet(i)) then - tsfc3(i,3) = max(271.2,Sfcprop%tref(i) + dtzm(i)) + tsfc3(i,3) = max(tgice,Sfcprop%tref(i) + dtzm(i)) ! tsfc3(i,3) = max(271.2,Sfcprop%tref(i) + dtzm(i)) - & ! (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse endif From b9af9ee91916f2bf354afb030d231b142eb8c040 Mon Sep 17 00:00:00 2001 From: "Jessica.Meixner" Date: Wed, 23 Oct 2019 01:44:51 +0000 Subject: [PATCH 03/91] adding import field of z0 surface roughness length and cplwav2atm flag for coupling wave to atm --- atmos_model.F90 | 21 +++++++++++++++++++++ cpl/module_cplfields.F90 | 11 +++++++---- gfsphysics/GFS_layer/GFS_typedefs.F90 | 16 ++++++++++++++-- namphysics/NAM_layer/NAM_typedefs.F90 | 17 +++++++++++++++-- 4 files changed, 57 insertions(+), 8 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 23e30e76c..0746b0fdb 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1641,6 +1641,27 @@ subroutine assign_importdata(rc) ! endif ! endif + +! get sea-state dependent surface roughness (if cplwav2atm=true) +!---------------------------- + fldname = 'wave_z0_roughness_length' + findex = QueryFieldList(ImportFieldsList,fldname) + if (importFieldsValid(findex) .and. datar8(isc,jsc) > -99999.0) then + if (trim(impfield_name) == trim(fldname) .and. found) then +!$omp parallel do default(shared) private(i,j,nb,ix) + do j=jsc,jec + do i=isc,iec + nb = Atm_block%blkno(i,j) + ix = Atm_block%ixp(i,j) + IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = datar8(i,j) + enddo + enddo + endif + endif +!JDM TO DO: Coupling%zorlwav_cpl +! if ocean point with incoming wave z0 set +! IPD_Data(nb)%Sfcprop%zorl(ix) = IPD_Data(nb)%Coupling%zorlwav_cpl(ix) + ! get sea ice surface temperature !-------------------------------- fldname = 'sea_ice_surface_temperature' diff --git a/cpl/module_cplfields.F90 b/cpl/module_cplfields.F90 index 48997ce4f..82c04cd2e 100644 --- a/cpl/module_cplfields.F90 +++ b/cpl/module_cplfields.F90 @@ -139,7 +139,7 @@ module module_cplfields real(kind=8), allocatable, public :: exportData(:,:,:) ! Import Fields ---------------------------------------- - integer, public, parameter :: NimportFields = 16 + integer, public, parameter :: NimportFields = 17 logical, public :: importFieldsValid(NimportFields) type(ESMF_Field), target, public :: importFields(NimportFields) character(len=*), public, parameter :: importFieldsList(NimportFields) = (/ & @@ -163,13 +163,15 @@ module module_cplfields "inst_tracer_up_surface_flx ", & "inst_tracer_down_surface_flx ", & "inst_tracer_clmn_mass_dens ", & - "inst_tracer_anth_biom_flx " & + "inst_tracer_anth_biom_flx ", & + "wave_z0_roughness_length " & /) character(len=*), public, parameter :: importFieldTypes(NimportFields) = (/ & "t", & "s","s","s","s","s", & "s","s","s","s","s", & - "s","u","d","c","b" & + "s","u","d","c","b", & + "s" & /) ! Set importFieldShare to .true. if field is provided as memory reference ! from coupled components @@ -177,7 +179,8 @@ module module_cplfields .true. , & .false.,.false.,.false.,.false.,.false., & .false.,.false.,.false.,.false.,.false., & - .false.,.true. ,.true. ,.true. ,.true. & + .false.,.true. ,.true. ,.true. ,.true. , & + .false. & /) ! Methods diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 65f6d30de..471701623 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -415,7 +415,8 @@ module GFS_typedefs real (kind=kind_phys), pointer :: ficein_cpl(:) => null() !< aoi_fld%ficein(item,lan) real (kind=kind_phys), pointer :: hicein_cpl(:) => null() !< aoi_fld%hicein(item,lan) real (kind=kind_phys), pointer :: hsnoin_cpl(:) => null() !< aoi_fld%hsnoin(item,lan) - !--- only variable needed for cplwav=.TRUE. + !--- only variable needed for cplwav2atm=.TRUE. + real (kind=kind_phys), pointer :: zorlwav_cpl(:) => null() !< roughness length from wave model !--- also needed for ice/ocn coupling - Xingren real (kind=kind_phys), pointer :: slimskin_cpl(:)=> null() !< aoi_fld%slimskin(item,lan) @@ -568,6 +569,7 @@ module GFS_typedefs !--- coupling parameters logical :: cplflx !< default no cplflx collection logical :: cplwav !< default no cplwav collection + logical :: cplwav2atm !< default no wav->atm coupling logical :: cplchm !< default no cplchm collection !--- integrated dynamics through earth's atmosphere @@ -2306,6 +2308,13 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%v10mi_cpl = clear_val endif + if (Model%cplwav2atm) then + !--- incoming quantities + allocate (Coupling%zorlwav_cpl (IM)) + + Coupling%zorlwav_cpl = clear_val + end if + if (Model%cplflx) then !--- incoming quantities allocate (Coupling%slimskin_cpl (IM)) @@ -2582,6 +2591,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- coupling parameters logical :: cplflx = .false. !< default no cplflx collection logical :: cplwav = .false. !< default no cplwav collection + logical :: cplwav2atm = .false. !< default no cplwav2atm coupling logical :: cplchm = .false. !< default no cplchm collection !--- integrated dynamics through earth's atmosphere @@ -2940,7 +2950,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & fhzero, ldiag3d, lssav, fhcyc, & thermodyn_id, sfcpress_id, & !--- coupling parameters - cplflx, cplwav, cplchm, lsidea, & + cplflx, cplwav, cplwav2atm, cplchm, lsidea, & !--- radiation parameters fhswr, fhlwr, levr, nfxr, aero_in, iflip, isol, ico2, ialb, & isot, iems, iaer, icliq_sw, iovr_sw, iovr_lw, ictm, isubc_sw,& @@ -3121,6 +3131,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- coupling parameters Model%cplflx = cplflx Model%cplwav = cplwav + Model%cplwav2atm = cplwav2atm Model%cplchm = cplchm !--- integrated dynamics through earth's atmosphere @@ -4163,6 +4174,7 @@ subroutine control_print(Model) print *, 'coupling parameters' print *, ' cplflx : ', Model%cplflx print *, ' cplwav : ', Model%cplwav + print *, ' cplwav2atm : ', Model%cplwav2atm print *, ' cplchm : ', Model%cplchm print *, ' ' print *, 'integrated dynamics through earth atmosphere' diff --git a/namphysics/NAM_layer/NAM_typedefs.F90 b/namphysics/NAM_layer/NAM_typedefs.F90 index 3dfa88530..09f8dca9d 100644 --- a/namphysics/NAM_layer/NAM_typedefs.F90 +++ b/namphysics/NAM_layer/NAM_typedefs.F90 @@ -325,7 +325,9 @@ module GFS_typedefs real (kind=kind_phys), pointer :: ficein_cpl(:) => null() !< aoi_fld%ficein(item,lan) real (kind=kind_phys), pointer :: hicein_cpl(:) => null() !< aoi_fld%hicein(item,lan) real (kind=kind_phys), pointer :: hsnoin_cpl(:) => null() !< aoi_fld%hsnoin(item,lan) - !--- only variable needed for cplwav=.TRUE. + !--- only variable needed for cplwav2atm=.TRUE. + real (kind=kind_phys), pointer :: zorlwav_cpl(:) => null() !< roughness length from wave model + !--- also needed for ice/ocn coupling - Xingren real (kind=kind_phys), pointer :: slimskin_cpl(:)=> null() !< aoi_fld%slimskin(item,lan) @@ -453,6 +455,7 @@ module GFS_typedefs !--- coupling parameters logical :: cplflx !< default no cplflx collection logical :: cplwav !< default no cplwav collection + logical :: cplwav2atm !< default no cplwav2atm coupling logical :: cplchm !< default no cplchm collection !--- integrated dynamics through earth's atmosphere @@ -1664,6 +1667,13 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%v10mi_cpl = clear_val endif + if (Model%cplwav2atm) then + !--- incoming quantities + allocate (Coupling%zorlwav_cpl (IM)) + + Coupling%zorlwav_cpl = clear_val + end if + if (Model%cplflx) then !--- incoming quantities allocate (Coupling%slimskin_cpl (IM)) @@ -1921,6 +1931,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- coupling parameters logical :: cplflx = .false. !< default no cplflx collection logical :: cplwav = .false. !< default no cplwav collection + logical :: cplwav2atm = .false. !< default no wav2atm coupling logical :: cplchm = .false. !< default no cplchm collection !--- integrated dynamics through earth's atmosphere @@ -2166,7 +2177,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & fhzero, ldiag3d, lssav, fhcyc, & thermodyn_id, sfcpress_id, & !--- coupling parameters - cplflx, cplwav, cplchm, lsidea, & + cplflx, cplwav, cplwav2atm, cplchm, lsidea, & !--- radiation parameters fhswr, fhlwr, levr, nfxr, aero_in, iflip, isol, ico2, ialb, & isot, iems, iaer, iovr_sw, iovr_lw, ictm, isubc_sw, & @@ -2362,6 +2373,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- coupling parameters Model%cplflx = cplflx Model%cplwav = cplwav + Model%cplwav2atm = cplwav2atm Model%cplchm = cplchm !--- integrated dynamics through earth's atmosphere @@ -3188,6 +3200,7 @@ subroutine control_print(Model) print *, 'coupling parameters' print *, ' cplflx : ', Model%cplflx print *, ' cplwav : ', Model%cplwav + print *, ' cplwav2atm : ', Model%cplwav2atm print *, ' cplchm : ', Model%cplchm print *, ' ' print *, 'integrated dynamics through earth atmosphere' From b65485fdf502ad30c9c9136358ec09e6a2b231e0 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 23 Oct 2019 17:14:56 +0000 Subject: [PATCH 04/91] removing 271.2 near line 1884 --- atmos_model.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 620366227..e8472bb68 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1884,7 +1884,7 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) else - IPD_Data(nb)%Sfcprop%tisfc(ix) = max(IPD_Data(nb)%Coupling%tseain_cpl(ix), 271.2) + IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) IPD_Data(nb)%Sfcprop%fice(ix) = zero IPD_Data(nb)%Sfcprop%hice(ix) = zero IPD_Data(nb)%Sfcprop%snowd(ix) = zero From 73e71f65f112426d43e6e9b872cadc1f5acfa072 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 24 Oct 2019 00:04:40 +0000 Subject: [PATCH 05/91] minor update of atmos_model.F90 --- atmos_model.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index e8472bb68..9f19aefd5 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1705,8 +1705,8 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Coupling%ficein_cpl(ix) = datar8(i,j) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4. - else - if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = zero + elseif (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) then + IPD_Data(nb)%Sfcprop%slmsk(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero endif endif From b8bb84448cd24905d6beb89d6968373de047f08d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 28 Oct 2019 18:32:59 +0000 Subject: [PATCH 06/91] updating GFS_typedef for includeing ras in ccpp, plus minor mod in physics driver --- .gitmodules | 6 +++ gfsphysics/GFS_layer/GFS_physics_driver.F90 | 2 +- gfsphysics/GFS_layer/GFS_typedefs.F90 | 15 +++++--- gfsphysics/GFS_layer/GFS_typedefs.meta | 41 ++++++++++++++++++--- 4 files changed, 52 insertions(+), 12 deletions(-) diff --git a/.gitmodules b/.gitmodules index fb33a8b44..f8e75f557 100644 --- a/.gitmodules +++ b/.gitmodules @@ -2,3 +2,9 @@ path = atmos_cubed_sphere url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere branch = dev/emc +[submodule "ccpp/framework"] + path = ccpp/framework + url = https://github.com/NCAR/ccpp-framework +[submodule "ccpp/physics"] + path = ccpp/physics + url = https://github.com/SMoorthi-EMC/ccpp-physics diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index d04bcae33..c4aa7582c 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -1155,7 +1155,7 @@ subroutine GFS_physics_driver & if (fice(i) < one) then wet(i) = .true. ! Sfcprop%tsfco(i) = tgice -! Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) + if (.not. Model%cplflx) Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) ! Sfcprop%tsfco(i) = max((Sfcprop%tsfc(i) - fice(i)*sfcprop%tisfc(i)) & ! / (one - fice(i)), tgice) endif diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 7ea1b598f..351c6510d 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -1009,9 +1009,9 @@ module GFS_typedefs #endif integer :: jdat(1:8) !< current forecast date and time !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) - integer :: imn !< current forecast month - integer :: julian !< current forecast julian date - integer :: yearlen !< current length of the year + integer :: imn !< initial forecast month + real(kind=kind_phys) :: julian !< julian day using midnight of January 1 of forecast year as initial epoch + integer :: yearlen !< length of the current forecast year in days ! logical :: iccn !< using IN CCN forcing for MG2/3 #ifdef CCPP @@ -2865,7 +2865,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- fractional grid logical :: frac_grid = .false. !< flag for fractional grid real(kind=kind_phys) :: min_lakeice = 0.15d0 !< minimum lake ice value - real(kind=kind_phys) :: min_seaice = 1.0d-6 !< minimum sea ice value + real(kind=kind_phys) :: min_seaice = 1.0d-11 !< minimum sea ice value real(kind=kind_phys) :: rho_h2o = rhowater !< fresh water density !--- surface layer z0 scheme @@ -2905,7 +2905,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: iau_delthrs = 0 !< iau time interval (to scale increments) character(len=240) :: iau_inc_files(7) = '' !< list of increment files real(kind=kind_phys) :: iaufhrs(7) = -1 !< forecast hours associated with increment files - logical :: iau_filter_increments = .false. !< filter IAU increments + logical :: iau_filter_increments = .false.!< filter IAU increments !--- debug flag logical :: debug = .false. @@ -3617,6 +3617,11 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- ps is replaced with p0. The value of p0 uses that in http://www.emc.ncep.noaa.gov/officenotes/newernotes/on461.pdf !--- ak/bk have been flipped from their original FV3 orientation and are defined sfc -> toa Model%si = (ak + bk * con_p0 - ak(Model%levr+1)) / (con_p0 - ak(Model%levr+1)) + + if (Model%lsm == Model%lsm_noahmp) then + Model%yearlen = 365 + Model%julian = -9999. + endif #endif #ifndef CCPP diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index f05354d7f..88fbc5a66 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -1977,6 +1977,20 @@ dimensions = (2) type = real kind = kind_phys +[psauras] + standard_name = coefficient_from_cloud_ice_to_snow_ras + long_name = conversion coefficient from cloud ice to snow in ras + units = none + dimensions = (2) + type = real + kind = kind_phys +[prauras] + standard_name = coefficient_from_cloud_water_to_rain_ras + long_name = conversion coefficient from cloud water to rain in ras + units = none + dimensions = (2) + type = real + kind = kind_phys [evpco] standard_name = coefficient_for_evaporation_of_rainfall long_name = coeff for evaporation of largescale rain @@ -1991,6 +2005,20 @@ dimensions = (2) type = real kind = kind_phys +[wminras] + standard_name = cloud_condensed_water_ice_conversion_threshold_ras + long_name = conversion coefficient from cloud liquid and ice to precipitation in ras + units = none + dimensions = (2) + type = real + kind = kind_phys +[dlqf] + standard_name = condensate_fraction_detrained_in_updraft_layers + long_name = condensate fraction detrained with in a updraft layers + units = none + dimensions = (2) + type = real + kind = kind_phys [avg_max_length] standard_name = time_interval_for_maximum_hourly_fields long_name = reset time interval for maximum hourly fields @@ -2308,12 +2336,6 @@ units = index dimensions = () type = integer -[mom4ice] - standard_name = flag_for_mom4_coupling - long_name = flag controls mom4 sea ice - units = flag - dimensions = () - type = logical [ras] standard_name = flag_for_ras_deep_convection long_name = flag for ras convection scheme @@ -2522,6 +2544,13 @@ standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag long_name = multiplication factors for cdmb and gwd units = none + dimensions = (4) + type = real + kind = kind_phys +[ccwf] + standard_name = multiplication_factor_for_critical_cloud_workfunction + long_name = multiplication factor for tical_cloud_workfunction + units = none dimensions = (2) type = real kind = kind_phys From c8840e9a20028920717aab1d8f728b32c445458c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 28 Oct 2019 23:22:10 +0000 Subject: [PATCH 07/91] after merging with Jessica's wave update in fv3 --- atmos_model.F90 | 22 +++++++++++----------- io/FV3GFS_io.F90 | 2 +- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index d7a0fc23b..a65a348c1 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1645,20 +1645,20 @@ subroutine assign_importdata(rc) ! get sea-state dependent surface roughness (if cplwav2atm=true) !---------------------------- - fldname = 'wave_z0_roughness_length' - findex = QueryFieldList(ImportFieldsList,fldname) - if (importFieldsValid(findex) .and. datar8(isc,jsc) > -99999.0) then - if (trim(impfield_name) == trim(fldname) .and. found) then + fldname = 'wave_z0_roughness_length' + if (trim(impfield_name) == trim(fldname)) then + findex = QueryFieldList(ImportFieldsList,fldname) + if (importFieldsValid(findex)) then !$omp parallel do default(shared) private(i,j,nb,ix) - do j=jsc,jec - do i=isc,iec - nb = Atm_block%blkno(i,j) - ix = Atm_block%ixp(i,j) - IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = datar8(i,j) + do j=jsc,jec + do i=isc,iec + nb = Atm_block%blkno(i,j) + ix = Atm_block%ixp(i,j) + IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = datar8(i,j) + enddo enddo - enddo + endif endif - endif !JDM TO DO: Coupling%zorlwav_cpl ! if ocean point with incoming wave z0 set ! IPD_Data(nb)%Sfcprop%zorl(ix) = IPD_Data(nb)%Coupling%zorlwav_cpl(ix) diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index a73a19084..990c670d1 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1119,7 +1119,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%lakefrac(ix) = 0.0 else Sfcprop(nb)%landfrac(ix) = 0.0 - if (Sfcprop(nb)%oro_uf(ix) > 0.01) then + if (Sfcprop(nb)%oro_uf(ix) > 1.00) then Sfcprop(nb)%lakefrac(ix) = 1.0 ! lake else Sfcprop(nb)%lakefrac(ix) = 0.0 ! ocean From 6f86c4bf03438373086cbecb48966ba5b37048d6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 2 Nov 2019 23:48:10 +0000 Subject: [PATCH 08/91] coupling with ww3 --- atmos_model.F90 | 14 ++++--- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 26 ++++++------ gfsphysics/GFS_layer/GFS_typedefs.F90 | 2 + gfsphysics/physics/sfc_diff.f | 44 +++++++++++---------- io/FV3GFS_io.F90 | 2 +- 5 files changed, 49 insertions(+), 39 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index a65a348c1..c4df8bfe4 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1575,6 +1575,7 @@ subroutine assign_importdata(rc) real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: datar42d real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d real(kind=IPD_kind_phys), dimension(:,:), pointer :: datar8 + real(kind=IPD_kind_phys) :: tem logical found, isFieldCreated, lcpl_fice ! !------------------------------------------------------------------------------ @@ -1648,20 +1649,22 @@ subroutine assign_importdata(rc) fldname = 'wave_z0_roughness_length' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) - if (importFieldsValid(findex)) then + if (importFieldsValid(findex) .and. IPD_control%cplwav2atm) then !$omp parallel do default(shared) private(i,j,nb,ix) do j=jsc,jec do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = datar8(i,j) + if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then + tem = 100.0 * max(zero, min(0.1, datar8(i,j))) + IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem + IPD_Data(nb)%Sfcprop%zorlo(ix) = tem + + endif enddo enddo endif endif -!JDM TO DO: Coupling%zorlwav_cpl -! if ocean point with incoming wave z0 set -! IPD_Data(nb)%Sfcprop%zorl(ix) = IPD_Data(nb)%Coupling%zorlwav_cpl(ix) ! get sea ice surface temperature !-------------------------------- @@ -1921,6 +1924,7 @@ subroutine assign_importdata(rc) enddo enddo endif +! !------------------------------------------------------------------------------- ! do j=jsc,jec ! do i=isc,iec diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index c4aa7582c..6866a0b19 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -1129,9 +1129,7 @@ subroutine GFS_physics_driver & fice(i) = zero endif ! ocean/lake area that is not frozen - tem1 = max(zero, tem - Sfcprop%fice(i)) - - if (tem1 > zero) then + if (tem-fice(i) > epsln) then wet(i) = .true. ! there is some open water! ! if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), tgice) ! if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) @@ -1197,11 +1195,16 @@ subroutine GFS_physics_driver & ! DH* In CCPP, this is in GFS_surface_composites_pre if (.not. Model%cplflx .or. .not. Model%frac_grid) then - do i=1,im - Sfcprop%zorll(i) = Sfcprop%zorl(i) - Sfcprop%zorlo(i) = Sfcprop%zorl(i) -! Sfcprop%tisfc(i) = Sfcprop%tsfc(i) - enddo + if (Model%cplwav2atm) then + do i=1,im + Sfcprop%zorll(i) = Sfcprop%zorl(i) + enddo + else + do i=1,im + Sfcprop%zorll(i) = Sfcprop%zorl(i) + Sfcprop%zorlo(i) = Sfcprop%zorl(i) + enddo + endif endif do i=1,im if(wet(i)) then ! Water @@ -1680,7 +1683,7 @@ subroutine GFS_physics_driver & if (Model%cplflx) then tem1 = half / omz1 do i=1,im - if (wet(i)) then + if (wet(i) .and. Sfcprop%oceanfrac(i) > zero) then tem2 = one / Sfcprop%xz(i) dt_warm = (Sfcprop%xt(i)+Sfcprop%xt(i)) * tem2 if ( Sfcprop%xz(i) > omz1) then @@ -1691,7 +1694,7 @@ subroutine GFS_physics_driver & - Sfcprop%z_c(i)*Sfcprop%dt_cool(i))*tem1 endif TSEAl(i) = Sfcprop%tref(i) + dt_warm - Sfcprop%dt_cool(i) -! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse +! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse tsurf3(i,3) = TSEAl(i) endif enddo @@ -1735,8 +1738,7 @@ subroutine GFS_physics_driver & zsea1 = 0.001*real(Model%nstf_name(4)) zsea2 = 0.001*real(Model%nstf_name(5)) call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & - Sfcprop%z_c, wet, zsea1, zsea2, & - im, 1, dtzm) + Sfcprop%z_c, wet, zsea1, zsea2, im, 1, dtzm) do i=1,im ! if (wet(i) .and. .not.icy(i)) then ! if (wet(i) .and. (Model%frac_grid .or. .not. icy(i))) then diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index fa39570c4..acce1bfa7 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -2883,6 +2883,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< 0=no change !< 6=areodynamical roughness over water with input 10-m wind !< 7=slightly decrease Cd for higher wind speed compare to 6 + !< negative when cplwav2atm=.true. - i.e. two way wave coupling !--- background vertical diffusion real(kind=kind_phys) :: xkzm_m = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum @@ -3423,6 +3424,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- surface layer Model%sfc_z0_type = sfc_z0_type + if (Model%cplwav2atm) Model%sfc_z0_type = -1 !--- backgroud vertical diffusion Model%xkzm_m = xkzm_m diff --git a/gfsphysics/physics/sfc_diff.f b/gfsphysics/physics/sfc_diff.f index d1da89c3d..ea08f5056 100644 --- a/gfsphysics/physics/sfc_diff.f +++ b/gfsphysics/physics/sfc_diff.f @@ -224,7 +224,7 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) call znot_t_v6(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type == 7) then call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) - else if (sfc_z0_type /= 0) then + else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type stop endif @@ -238,31 +238,33 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) ! ! update z0 over ocean ! - if (sfc_z0_type == 0) then - z0 = (charnock / grav) * ustar(i,3) * ustar(i,3) + if (sfc_z0_type >= 0) then + if (sfc_z0_type == 0) then + z0 = (charnock / grav) * ustar(i,3) * ustar(i,3) ! mbek -- toga-coare flux algorithm -! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) +! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) ! new implementation of z0 -! cc = ustar(i) * z0 / rnu -! pp = cc / (1. + cc) -! ff = grav * arnu / (charnock * ustar(i) ** 3) -! z0 = arnu / (ustar(i) * ff ** pp) - - if (redrag) then - z0rl(i,3) = 100.0 * max(min(z0, z0s_max), 1.e-7) +! cc = ustar(i) * z0 / rnu +! pp = cc / (1. + cc) +! ff = grav * arnu / (charnock * ustar(i) ** 3) +! z0 = arnu / (ustar(i) * ff ** pp) + + if (redrag) then + z0rl(i,3) = 100.0 * max(min(z0, z0s_max), 1.e-7) + else + z0rl(i,3) = 100.0 * max(min(z0,.1), 1.e-7) + endif + + elseif (sfc_z0_type == 6) then ! wang + call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m + z0rl(i,3) = 100.0 * z0 ! cm + elseif (sfc_z0_type == 7) then ! wang + call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m + z0rl(i,3) = 100.0 * z0 ! cm else - z0rl(i,3) = 100.0 * max(min(z0,.1), 1.e-7) + z0rl(i,3) = 1.0e-4 endif - - elseif (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m - z0rl(i,3) = 100.0 * z0 ! cm - elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m - z0rl(i,3) = 100.0 * z0 ! cm - else - z0rl(i,3) = 1.0e-4 endif endif ! end of if(open ocean) diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 990c670d1..f1adc58f7 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1119,7 +1119,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%lakefrac(ix) = 0.0 else Sfcprop(nb)%landfrac(ix) = 0.0 - if (Sfcprop(nb)%oro_uf(ix) > 1.00) then + if (Sfcprop(nb)%oro_uf(ix) > 25.00) then Sfcprop(nb)%lakefrac(ix) = 1.0 ! lake else Sfcprop(nb)%lakefrac(ix) = 0.0 ! ocean From ac9195cab5b55478d8a465dcee5f34672e63fd08 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 6 Nov 2019 00:24:19 +0000 Subject: [PATCH 09/91] after merging with fv3atm develop branch and updating for ras --- atmos_cubed_sphere | 2 +- ccpp/config/ccpp_prebuild_config.py | 1 + ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_typedefs.F90 | 6 ------ 4 files changed, 3 insertions(+), 8 deletions(-) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 8dd7628b3..786447c83 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 8dd7628b3e2d1db8a48d877b9fe561be66bbf472 +Subproject commit 786447c8391a6806cd7b869bfa9dca69e3c95a48 diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config.py index b1738d633..e5f607fcc 100755 --- a/ccpp/config/ccpp_prebuild_config.py +++ b/ccpp/config/ccpp_prebuild_config.py @@ -213,6 +213,7 @@ 'FV3/ccpp/physics/physics/precpd.f' : [ 'slow_physics' ], 'FV3/ccpp/physics/physics/radlw_main.f' : [ 'slow_physics' ], 'FV3/ccpp/physics/physics/radsw_main.f' : [ 'slow_physics' ], + 'FV3/ccpp/physics/physics/rascnv.F90' : [ 'slow_physics' ], 'FV3/ccpp/physics/physics/rayleigh_damp.f' : [ 'slow_physics' ], 'FV3/ccpp/physics/physics/rrtmg_lw_post.F90' : [ 'slow_physics' ], 'FV3/ccpp/physics/physics/rrtmg_lw_pre.F90' : [ 'slow_physics' ], diff --git a/ccpp/physics b/ccpp/physics index d4b1cd020..51c13beef 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d4b1cd020f8347147b86d3a18b56c03cb5c57d67 +Subproject commit 51c13beef8b36036b5a9ac34b7951fe20b1d4eb2 diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index c39713b0e..ec8be1620 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -1017,15 +1017,9 @@ module GFS_typedefs #endif integer :: jdat(1:8) !< current forecast date and time !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) -<<<<<<< HEAD integer :: imn !< initial forecast month real(kind=kind_phys) :: julian !< julian day using midnight of January 1 of forecast year as initial epoch integer :: yearlen !< length of the current forecast year in days -======= - integer :: imn !< current forecast month - real(kind=kind_phys) :: julian !< current forecast julian date - integer :: yearlen !< current length of the year ->>>>>>> 45dbc34bdb8cf2d6d3ed1fc0b0067d00be8422d8 ! logical :: iccn !< using IN CCN forcing for MG2/3 #ifdef CCPP From 393bc62808bcc5104e7f18ad97e1b5d8edde08c5 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 29 Dec 2019 00:37:54 +0000 Subject: [PATCH 10/91] FV3 updates for RAS MG3 SHOC so that IPD and CCPP reproduce in REPRO mode --- ccpp/physics | 2 +- ccpp/suites/suite_FV3_GFS_rasmgshoc.xml | 91 +++++ ccpp/suites/suite_FV3_GFS_v15.xml | 1 - ccpp/suites/suite_FV3_GFS_v15_ras.xml | 93 +++++ ccpp/suites/suite_FV3_GFS_v15_rasmgshoc.xml | 88 ++++ ccpp/suites/suite_FV3_GFS_v15plusras.xml | 94 +++++ gfsphysics/GFS_layer/GFS_driver.F90 | 4 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 432 +++++++++++--------- gfsphysics/GFS_layer/GFS_typedefs.F90 | 69 ++-- gfsphysics/GFS_layer/GFS_typedefs.meta | 6 + gfsphysics/physics/gcm_shoc.f90 | 69 ++-- gfsphysics/physics/m_micro_driver.F90 | 29 +- gfsphysics/physics/micro_mg2_0.F90 | 94 ++--- gfsphysics/physics/micro_mg3_0.F90 | 25 +- gfsphysics/physics/micro_mg_utils.F90 | 247 ++++++----- gfsphysics/physics/moninshoc.f | 16 +- gfsphysics/physics/rascnvv2.f | 61 ++- gfsphysics/physics/ugwp_driver_v0.f | 4 +- io/FV3GFS_io.F90 | 2 +- 19 files changed, 969 insertions(+), 458 deletions(-) create mode 100644 ccpp/suites/suite_FV3_GFS_rasmgshoc.xml create mode 100644 ccpp/suites/suite_FV3_GFS_v15_ras.xml create mode 100644 ccpp/suites/suite_FV3_GFS_v15_rasmgshoc.xml create mode 100644 ccpp/suites/suite_FV3_GFS_v15plusras.xml diff --git a/ccpp/physics b/ccpp/physics index 51c13beef..62fb748a3 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 51c13beef8b36036b5a9ac34b7951fe20b1d4eb2 +Subproject commit 62fb748a3cacaa78e34dea5f1791eaed91af9094 diff --git a/ccpp/suites/suite_FV3_GFS_rasmgshoc.xml b/ccpp/suites/suite_FV3_GFS_rasmgshoc.xml new file mode 100644 index 000000000..4f05dce54 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_rasmgshoc.xml @@ -0,0 +1,91 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + moninshoc + GFS_PBL_generic_post + GFS_GWD_generic_pre + gwdps + gwdps_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + GFS_DCNV_generic_pre + get_phi_fv3 + GFS_suite_interstitial_3 + shoc + GFS_suite_interstitial_5 + rascnv + GFS_DCNV_generic_post + gwdc_pre + gwdc + gwdc_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + m_micro_pre + m_micro + m_micro_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + diff --git a/ccpp/suites/suite_FV3_GFS_v15.xml b/ccpp/suites/suite_FV3_GFS_v15.xml index 672c39280..0bbe186f5 100644 --- a/ccpp/suites/suite_FV3_GFS_v15.xml +++ b/ccpp/suites/suite_FV3_GFS_v15.xml @@ -54,7 +54,6 @@ GFS_surface_composites_post - dcyc2t3_post sfc_diag sfc_diag_post GFS_surface_generic_post diff --git a/ccpp/suites/suite_FV3_GFS_v15_ras.xml b/ccpp/suites/suite_FV3_GFS_v15_ras.xml new file mode 100644 index 000000000..e715206f9 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_v15_ras.xml @@ -0,0 +1,93 @@ + + + + + + + fv_sat_adj + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + hedmf + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + GFS_DCNV_generic_pre + get_phi_fv3 + GFS_suite_interstitial_3 + rascnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + samfshalcnv_post + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + gfdl_cloud_microphys + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + diff --git a/ccpp/suites/suite_FV3_GFS_v15_rasmgshoc.xml b/ccpp/suites/suite_FV3_GFS_v15_rasmgshoc.xml new file mode 100644 index 000000000..93f3abac9 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_v15_rasmgshoc.xml @@ -0,0 +1,88 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + moninshoc + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + shoc + GFS_DCNV_generic_pre + GFS_suite_interstitial_5 + rascnv + GFS_DCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + m_micro_pre + m_micro + m_micro_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + diff --git a/ccpp/suites/suite_FV3_GFS_v15plusras.xml b/ccpp/suites/suite_FV3_GFS_v15plusras.xml new file mode 100644 index 000000000..0bb4b21a5 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_v15plusras.xml @@ -0,0 +1,94 @@ + + + + + + + fv_sat_adj + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + dcyc2t3_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + satmedmfvdif + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + GFS_DCNV_generic_pre + get_phi_fv3 + GFS_suite_interstitial_3 + rascnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + samfshalcnv_post + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + gfdl_cloud_microphys + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + diff --git a/gfsphysics/GFS_layer/GFS_driver.F90 b/gfsphysics/GFS_layer/GFS_driver.F90 index e73343782..21c9f2d7a 100644 --- a/gfsphysics/GFS_layer/GFS_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_driver.F90 @@ -332,7 +332,7 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & call ini_micro (Model%mg_dcs, Model%mg_qcvar, Model%mg_ts_auto_ice(1)) elseif (Model%fprcp == 1) then call micro_mg_init2_0(kind_phys, gravit, rair, rh2o, cpair, & - tmelt, latvap, latice, 1.01_kind_phys, & + tmelt, latvap, latice, Model%mg_rhmini, & Model%mg_dcs, Model%mg_ts_auto_ice, & Model%mg_qcvar, & Model%microp_uniform, Model%do_cldice, & @@ -345,7 +345,7 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & Model%mg_ncnst, Model%mg_ninst) elseif (Model%fprcp == 2) then call micro_mg_init3_0(kind_phys, gravit, rair, rh2o, cpair, & - tmelt, latvap, latice, 1.01_kind_phys, & + tmelt, latvap, latice, Model%mg_rhmini, & Model%mg_dcs, Model%mg_ts_auto_ice, & Model%mg_qcvar, & Model%mg_do_hail, Model%mg_do_graupel, & diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index b28adc377..c0acf1868 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -818,8 +818,12 @@ subroutine GFS_physics_driver & ! lprnt = .false. ! do i=1,im -! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-29.55) < 0.201 & -! .and. abs(grid%xlat(i)*rad2dg+59.62) < 0.201 +! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-97.50) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-24.48) < 0.101 +! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-293.91) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg+72.02) < 0.101 +! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-113.48) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-21.07) < 0.101 ! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-169.453) < 0.501 & ! .and. abs(grid%xlat(i)*rad2dg-72.96) < 0.501 ! if (kdt == 1) & @@ -1977,8 +1981,8 @@ subroutine GFS_physics_driver & Sfcprop%tsfc(i) = txl*tsfc3(i,1) + txi*tice(i) + txo*tsfc3(i,3) ! Sfcprop%tsfc(i) = txl*tsfc3(i,1) + txi*tsfc3(i,2) + txo*tsfc3(i,3) - Diag%cmm(i) = txl*cmm3(i,1) + txi*cmm3(i,2) + txo*cmm3(i,3) - Diag%chh(i) = txl*chh3(i,1) + txi*chh3(i,2) + txo*chh3(i,3) +! Diag%cmm(i) = txl*cmm3(i,1) + txi*cmm3(i,2) + txo*cmm3(i,3) +! Diag%chh(i) = txl*chh3(i,1) + txi*chh3(i,2) + txo*chh3(i,3) Sfcprop%zorll(i) = zorl3(i,1) Sfcprop%zorlo(i) = zorl3(i,3) @@ -2265,12 +2269,16 @@ subroutine GFS_physics_driver & dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, Model%xkzminv, & lprnt, ipr, me) -! if (lprnt) write(0,*)'aftmonshoc=',Statein%tgrs(ipr,:) -! if (lprnt) write(0,*)'aftmonshocq=',Statein%qgrs(ipr,:,1) -! if (lprnt) write(0,*)'aftmonshoctke=',Statein%qgrs(ipr,:,ntke) -! if (lprnt) write(0,*)'aftmonice=',Statein%qgrs(ipr,:,ntiw) -! if (lprnt) write(0,*)'aftmonwat=',Statein%qgrs(ipr,:,ntcw) -! if (lprnt) write(0,*)'aftmonshocdtdt=',dtdt(ipr,1:10) +! if (lprnt) then +! write(0,*)' aftpbl dtdt=',dtdt(ipr,:) +! write(0,*)' aftpbl dqdtv=',dqdt(ipr,:,1) +! write(0,*)'aftmonshoc=',Statein%tgrs(ipr,:) +! write(0,*)'aftmonshocq=',Statein%qgrs(ipr,:,1) +! write(0,*)'aftmonshoctke=',Statein%qgrs(ipr,:,ntke) +! write(0,*)'aftmonice=',Statein%qgrs(ipr,:,ntiw) +! write(0,*)'aftmonwat=',Statein%qgrs(ipr,:,ntcw) +! write(0,*)'aftmonshocdtdt=',dtdt(ipr,1:10) +! endif else if (Model%satmedmf) then if (Model%isatmedmf == 0) then ! initial version of satmedmfvdif (Nov 2018) @@ -2722,7 +2730,8 @@ subroutine GFS_physics_driver & endif ! if (lprnt) then -! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt,' lat=',lat +! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt +! write(0,*) ' dvsfc1=',dvsfc1(ipr),' kdt=',kdt ! write(0,*)' dtsfc1=',dtsfc1(ipr) ! write(0,*)' dqsfc1=',dqsfc1(ipr) ! write(0,*)' dtdtc=',(dtdt(ipr,k),k=1,15) @@ -3165,10 +3174,10 @@ subroutine GFS_physics_driver & ! print *,' dtdt=',dtdt(ipr,:) ! print *,' gu0=',gu0(ipr,:) ! print *,' gv0=',gv0(ipr,:) -! write(0,*) ' gt0=',(gt0(ipr,k),k=1,levs),' kdt=',kdt -! write(0,*)' gq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat -! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat -! write(0,*)' gq1=',(gq0(ipr,k,ntcw),k=1,levs) +! write(0,*) ' gt0=',(Stateout%gt0(ipr,k),k=1,levs),' kdt=',kdt +! write(0,*)' gq0=',(Stateout%gq0(ipr,k,1),k=1,levs) +! write(0,*)' gq0i2=',(Stateout%gq0(ipr,k,ntiw),k=1,levs) +! write(0,*)' gq1=',(Stateout%gq0(ipr,k,ntcw),k=1,levs) ! print *,' vvel=',vvel ! endif ! if (lprnt) write(7000,*)' bef convection gu0=',gu0(ipr,:) @@ -3231,6 +3240,7 @@ subroutine GFS_physics_driver & do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntlnc .and. n /= ntinc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then tracers = tracers + 1 do k=1,levs @@ -3352,6 +3362,11 @@ subroutine GFS_physics_driver & enddo rhc(:,:) = one endif + +! if (lprnt) write(0,*)' clwice=',clw(ipr,:,1) +! if (lprnt) write(0,*)' clwwat=',clw(ipr,:,2) +! if (lprnt) write(0,*)' rhc=',rhc(ipr,:) + ! ! Call SHOC if do_shoc is true and shocaftcnv is false ! @@ -3409,6 +3424,8 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)'gq01=',Stateout%gq0(ipr,:,1) ! if (lprnt) write(0,*)'clwi=',clw(ipr,:,1) ! if (lprnt) write(0,*)'clwl=',clw(ipr,:,2) +! if (lprnt) write(0,*)'befncpi=',ncpi(ipr,:) +! if (lprnt) write(0,*)'tkh=',Tbd%phy_f3d(ipr,:,ntot3d-1) ! if (lprnt) write(0,*) ' befshoc hflx=',hflx(ipr),' evap=',evap(ipr),& ! ' stress=',stress(ipr) ! dtshoc = 60.0 @@ -3447,6 +3464,7 @@ subroutine GFS_physics_driver & lprnt, ipr, imp_physics, ncpl, ncpi) +! if (lprnt) write(0,*)'aftncpi=',ncpi(ipr,:) ! enddo ! if (imp_physics == Model%imp_physics_mg .and. Model%fprcp > 1) then ! do k=1,levs @@ -3457,7 +3475,7 @@ subroutine GFS_physics_driver & ! endif ! if (lprnt) write(0,*)'aftshocgt0=',Stateout%gt0(ipr,:) -! if (lprnt) write(0,*)'aftshocgq0=',Stateout%gq0(ipr,1:60,1) +! if (lprnt) write(0,*)'aftshocgq0=',Stateout%gq0(ipr,:,1) ! if (lprnt) write(0,*)' aft shoc tke=',clw(ipr,1:25,ntk), & ! &' kdt=',kdt,'xlon=',grid%xlon(ipr),' xlat=',grid%xlat(ipr) ! if (lprnt) write(0,*)' aftshoccld=',tbd%phy_f3d(ipr,:,ntot3d-2)*100 @@ -3753,8 +3771,8 @@ subroutine GFS_physics_driver & ! trcmin) trcmin, ntk) -! if (lprnt) write(0,*)' gt04=',Stateout%gt0(ipr,1:60) -! if (lprnt) write(0,*)' gq04=',Stateout%gq0(ipr,1:60,1) +! if (lprnt) write(0,*)' gt04=',Stateout%gt0(ipr,:) +! if (lprnt) write(0,*)' gq04=',Stateout%gq0(ipr,:,1) ! if (lprnt) write(0,*)'aftrasclw1=',clw(ipr,:,1) ! if (lprnt) write(0,*)'aftrasclw2=',clw(ipr,:,2) ! if (lprnt) write(0,*)'aftrastke=',clw(ipr,:,ntk) @@ -3864,6 +3882,12 @@ subroutine GFS_physics_driver & ! !----------------Convective gravity wave drag parameterization starting -------- +! if (lprnt) then +! write(0,*) ' befgwgt0=',Stateout%gt0(ipr,:) +! write(0,*) ' befgwgq0=',Stateout%gq0(ipr,:,1) +! write(0,*) ' do_cnvgwd=',Model%do_cnvgwd +! endif + ! DH* this block is in gwdc_pre if (Model%do_cnvgwd) then ! call convective gravity wave drag @@ -4049,6 +4073,11 @@ subroutine GFS_physics_driver & deallocate(gwdcu, gwdcv) endif ! end if_cnvgwd (convective gravity wave drag) +! if (lprnt) then +! write(0,*) ' befgwegt0=',Stateout%gt0(ipr,:) +! write(0,*) ' befgwegq0=',Stateout%gq0(ipr,:,1) +! endif + ! if (lprnt) write(7000,*)' aft cnvgwd gu0=',gu0(ipr,:) ! if (lprnt) write(7000,*)' aft cnvgwd gv0=',gv0(ipr,:) ! &,' lat=',lat,' kdt=',kdt,' me=',me @@ -4101,6 +4130,10 @@ subroutine GFS_physics_driver & else nsamftrac = tottracer endif +! if (lprnt) then +! write(0,*) ' befshgt0=',Stateout%gt0(ipr,:) +! write(0,*) ' befshgq0=',Stateout%gq0(ipr,:,1) +! endif call samfshalcnv (im, ix, levs, dtp, itc, Model%ntchm, ntk, nsamftrac, & del, Statein%prsl, Statein%pgr, Statein%phil, clw, & Stateout%gq0(:,:,1), Stateout%gt0, & @@ -4308,6 +4341,7 @@ subroutine GFS_physics_driver & ! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntlnc .and. n /= ntinc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then tracers = tracers + 1 do k=1,levs @@ -4369,6 +4403,16 @@ subroutine GFS_physics_driver & enddo endif ! end if_ntcw +! if (lprnt) then +! write(0,*)' aft shallow physics kdt=',kdt +! write(0,*)'qt0s=',Stateout%gt0(ipr,:) +! write(0,*)'qq0s=',Stateout%gq0(ipr,:,1) +! write(0,*)'qq0ws=',Stateout%gq0(ipr,:,ntcw) +! write(0,*)'qq0is=',Stateout%gq0(ipr,:,ntiw) +! write(0,*)'qq0ntic=',Stateout%gq0(ipr,:,ntinc) +! write(0,*)'qq0os=',Stateout%gq0(ipr,:,ntoz) +! endif + ! Legacy routine which determines convectve clouds - should be removed at some point call cnvc90 (Model%clstp, im, ix, Diag%rainc, kbot, ktop, levs, Statein%prsi, & @@ -4563,97 +4607,97 @@ subroutine GFS_physics_driver & ims,ime, kms,kme, & its,ite, kts,kte) ! - elseif (imp_physics == Model%imp_physics_mg) then ! MGB double-moment microphysics + elseif (imp_physics == Model%imp_physics_mg) then ! MGB double-moment microphysics ! ------------------------------ - kk = 5 - if (Model%fprcp >= 2) kk = 6 + kk = 5 + if (Model%fprcp >= 2) kk = 6 ! Acheng used clw here for other code to run smoothly and minimum change ! to make the code work. However, the nc and clw should be treated ! in other procceses too. August 28/2015; Hope that can be done next ! year. I believe this will make the physical interaction more reasonable ! Anning 12/5/2015 changed ntcw hold liquid only - if (Model%do_shoc) then - skip_macro = Model%do_shoc - if (Model%fprcp == 0) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc + if (Model%do_shoc) then + skip_macro = Model%do_shoc + if (Model%fprcp == 0) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc + enddo enddo - enddo - elseif (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc + elseif (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + ncpr(i,k) = Stateout%gq0(i,k,ntrnc) + ncps(i,k) = Stateout%gq0(i,k,ntsnc) + Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc + enddo enddo - enddo - else - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - qgl(i,k) = Stateout%gq0(i,k,ntgl) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - ncgl(i,k) = Stateout%gq0(i,k,ntgnc) - Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc + else + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + qgl(i,k) = Stateout%gq0(i,k,ntgl) + ncpr(i,k) = Stateout%gq0(i,k,ntrnc) + ncps(i,k) = Stateout%gq0(i,k,ntsnc) + ncgl(i,k) = Stateout%gq0(i,k,ntgnc) + Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc + enddo enddo - enddo - endif + endif - else + else ! clouds from t-dt and cnvc - if (Model%fprcp == 0 ) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + if (Model%fprcp == 0 ) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + enddo enddo - enddo - elseif (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) + elseif (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + ncpr(i,k) = Stateout%gq0(i,k,ntrnc) + ncps(i,k) = Stateout%gq0(i,k,ntsnc) + enddo enddo - enddo - else - do k=1,levs - do i=1,im - clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice - clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water - qrn(i,k) = Stateout%gq0(i,k,ntrw) - qsnw(i,k) = Stateout%gq0(i,k,ntsw) - qgl(i,k) = Stateout%gq0(i,k,ntgl) - ncpr(i,k) = Stateout%gq0(i,k,ntrnc) - ncps(i,k) = Stateout%gq0(i,k,ntsnc) - ncgl(i,k) = Stateout%gq0(i,k,ntgnc) + else + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + qgl(i,k) = Stateout%gq0(i,k,ntgl) + ncpr(i,k) = Stateout%gq0(i,k,ntrnc) + ncps(i,k) = Stateout%gq0(i,k,ntsnc) + ncgl(i,k) = Stateout%gq0(i,k,ntgnc) + enddo enddo - enddo + endif endif - endif ! add convective cloud fraction - do k = 1,levs - do i = 1,im - Tbd%phy_f3d(i,k,1) = min(one, Tbd%phy_f3d(i,k,1) + clcn(i,k)) + do k = 1,levs + do i = 1,im + Tbd%phy_f3d(i,k,1) = min(one, Tbd%phy_f3d(i,k,1) + clcn(i,k)) + enddo enddo - enddo ! notice clw ix instead of im ! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi, @@ -4662,6 +4706,7 @@ subroutine GFS_physics_driver & ! if(lprnt) write(0,*) ' befgt0=',Stateout%gt0(ipr,:),' kdt=',kdt ! if(lprnt) write(0,*) ' befgq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt ! if(lprnt) write(0,*) ' befntlnc=',Stateout%gq0(ipr,:,ntlnc),' kdt=',kdt +! if(lprnt) write(0,*) ' befntinc=',Stateout%gq0(ipr,:,ntinc),' kdt=',kdt ! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt ! if (lprnt) write(0,*)' clw2bef=',clw(ipr,:,2),' kdt=',kdt ! if (lprnt) write(0,*)' qrnb=',qrn(ipr,:),' kdt=',kdt @@ -4676,30 +4721,30 @@ subroutine GFS_physics_driver & ! write(1000+me,*)' maxwatncb=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt',kdt ! enddo - call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & - Statein%prsi, Statein%phil, Statein%phii, & - Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & - Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & - FRLAND, Diag%HPBL, CNV_MFD, CNV_DQLDT, & -! FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & - Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & - CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,ntcw), & - Stateout%gq0(1,1,ntiw), Stateout%gt0, rain1, & - Diag%sr, Stateout%gq0(1,1,ntlnc), & - Stateout%gq0(1,1,ntinc), Model%fprcp, qrn, & - qsnw, qgl, ncpr, ncps, ncgl, & - Tbd%phy_f3d(1,1,1), kbot, & - Tbd%phy_f3d(1,1,2), Tbd%phy_f3d(1,1,3), & - Tbd%phy_f3d(1,1,4), Tbd%phy_f3d(1,1,5), & - Tbd%phy_f3d(1,1,kk), Tbd%aer_nm, & - Model%aero_in, Tbd%in_nm, Tbd%ccn_nm, Model%iccn, & - skip_macro, lprnt, & -! skip_macro, cn_prc, cn_snr, lprnt, & -! ipr, kdt, Grid%xlat, Grid%xlon) - Model%mg_alf, Model%mg_qcmin, Model%pdfflag, & - ipr, kdt, Grid%xlat, Grid%xlon, rhc) + call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & + Statein%prsi, Statein%phil, Statein%phii, & + Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & + Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & + FRLAND, Diag%HPBL, CNV_MFD, CNV_DQLDT, & +! FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & + Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & + CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,ntcw), & + Stateout%gq0(1,1,ntiw), Stateout%gt0, rain1, & + Diag%sr, Stateout%gq0(1,1,ntlnc), & + Stateout%gq0(1,1,ntinc), Model%fprcp, qrn, & + qsnw, qgl, ncpr, ncps, ncgl, & + Tbd%phy_f3d(1,1,1), kbot, & + Tbd%phy_f3d(1,1,2), Tbd%phy_f3d(1,1,3), & + Tbd%phy_f3d(1,1,4), Tbd%phy_f3d(1,1,5), & + Tbd%phy_f3d(1,1,kk), Tbd%aer_nm, & + Model%aero_in, Tbd%in_nm, Tbd%ccn_nm, Model%iccn, & + skip_macro, lprnt, & +! skip_macro, cn_prc, cn_snr, lprnt, & +! ipr, kdt, Grid%xlat, Grid%xlon) + Model%mg_alf, Model%mg_qcmin, Model%pdfflag, & + ipr, kdt, Grid%xlat, Grid%xlon, rhc) ! do k=1,levs ! write(1000+me,*)' maxwatnca=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt=',kdt ! enddo @@ -4719,7 +4764,7 @@ subroutine GFS_physics_driver & ! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr),' kdt=',kdt ! if(lprnt) write(0,*) ' aftgt0=',Stateout%gt0(ipr,:),' kdt=',kdt ! if (lprnt) write(0,*) ' aftlsgq0=',stateout%gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt +! if (lprnt) write(0,*)' cli1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt ! if (ntgl > 0 .and. lprnt) & ! write(0,*)' cgw1aft=',stateout%gq0(ipr,:,ntgl),' kdt=',kdt ! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt @@ -4728,43 +4773,43 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt ! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt - tem = dtp * con_p001 / con_day - if (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then - do k=1,levs + tem = dtp * con_p001 / con_day + if (abs(Model%fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + if (abs(qrn(i,k)) < qsmall) qrn(i,k) = zero + if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = zero + Stateout%gq0(i,k,ntrw) = qrn(i,k) + Stateout%gq0(i,k,ntsw) = qsnw(i,k) + Stateout%gq0(i,k,ntrnc) = ncpr(i,k) + Stateout%gq0(i,k,ntsnc) = ncps(i,k) + enddo + enddo do i=1,im - if (abs(qrn(i,k)) < qsmall) qrn(i,k) = zero - if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = zero - Stateout%gq0(i,k,ntrw) = qrn(i,k) - Stateout%gq0(i,k,ntsw) = qsnw(i,k) - Stateout%gq0(i,k,ntrnc) = ncpr(i,k) - Stateout%gq0(i,k,ntsnc) = ncps(i,k) + Diag%ice(i) = tem * Stateout%gq0(i,1,ntiw) + Diag%snow(i) = tem * qsnw(i,1) + enddo + elseif (Model%fprcp > 1) then + do k=1,levs + do i=1,im + if (abs(qrn(i,k)) < qsmall) qrn(i,k) = zero + if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = zero + if (abs(qgl(i,k)) < qsmall) qgl(i,k) = zero + Stateout%gq0(i,k,ntrw) = qrn(i,k) + Stateout%gq0(i,k,ntsw) = qsnw(i,k) + Stateout%gq0(i,k,ntgl) = qgl(i,k) + Stateout%gq0(i,k,ntrnc) = ncpr(i,k) + Stateout%gq0(i,k,ntsnc) = ncps(i,k) + Stateout%gq0(i,k,ntgnc) = ncgl(i,k) + enddo enddo - enddo - do i=1,im - Diag%ice(i) = tem * Stateout%gq0(i,1,ntiw) - Diag%snow(i) = tem * qsnw(i,1) - enddo - elseif (Model%fprcp > 1) then - do k=1,levs do i=1,im - if (abs(qrn(i,k)) < qsmall) qrn(i,k) = zero - if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = zero - if (abs(qgl(i,k)) < qsmall) qgl(i,k) = zero - Stateout%gq0(i,k,ntrw) = qrn(i,k) - Stateout%gq0(i,k,ntsw) = qsnw(i,k) - Stateout%gq0(i,k,ntgl) = qgl(i,k) - Stateout%gq0(i,k,ntrnc) = ncpr(i,k) - Stateout%gq0(i,k,ntsnc) = ncps(i,k) - Stateout%gq0(i,k,ntgnc) = ncgl(i,k) + Diag%ice(i) = tem * Stateout%gq0(i,1,ntiw) + Diag%snow(i) = tem * qsnw(i,1) + Diag%graupel(i) = tem * qgl(i,1) enddo - enddo - do i=1,im - Diag%ice(i) = tem * Stateout%gq0(i,1,ntiw) - Diag%snow(i) = tem * qsnw(i,1) - Diag%graupel(i) = tem * qgl(i,1) - enddo - endif + endif ! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt ! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt @@ -4830,20 +4875,20 @@ subroutine GFS_physics_driver & reset) tem = dtp * con_p001 / con_day do i = 1, im -! rain0(i,1) = max(con_d00, rain0(i,1)) -! snow0(i,1) = max(con_d00, snow0(i,1)) -! ice0(i,1) = max(con_d00, ice0(i,1)) -! graupel0(i,1) = max(con_d00, graupel0(i,1)) - if(rain0(i,1)*tem < rainmin) then - rain0(i,1) = zero +! rain0(i,1) = max(con_d00, rain0(i,1)) +! snow0(i,1) = max(con_d00, snow0(i,1)) +! ice0(i,1) = max(con_d00, ice0(i,1)) +! graupel0(i,1) = max(con_d00, graupel0(i,1)) + if (rain0(i,1)*tem < rainmin) then + rain0(i,1) = zero endif - if(ice0(i,1)*tem < rainmin) then + if (ice0(i,1)*tem < rainmin) then ice0(i,1) = zero endif - if(snow0(i,1)*tem < rainmin) then + if (snow0(i,1)*tem < rainmin) then snow0(i,1) = zero endif - if(graupel0(i,1)*tem < rainmin) then + if (graupel0(i,1)*tem < rainmin) then graupel0(i,1) = zero endif @@ -4883,7 +4928,7 @@ subroutine GFS_physics_driver & enddo - if(Model%effr_in) then + if (Model%effr_in) then do i =1, im den(i,k) = 0.622*Statein%prsl(i,k) / & (con_rd*Stateout%gt0(i,k)*(Stateout%gq0(i,k,1)+0.622)) @@ -4891,25 +4936,25 @@ subroutine GFS_physics_driver & endif enddo !Calculate hourly max 1-km agl and -10C reflectivity - if (Model%lradar .and. & - (imp_physics == Model%imp_physics_gfdl .or. & - imp_physics == Model%imp_physics_thompson)) then - allocate(refd(im)) - allocate(refd263k(im)) - call max_fields(Statein%phil,Diag%refl_10cm,con_g,im,levs,refd,Stateout%gt0,refd263k) - if (reset) then + if (Model%lradar .and. & + (imp_physics == Model%imp_physics_gfdl .or. & + imp_physics == Model%imp_physics_thompson)) then + allocate(refd(im)) + allocate(refd263k(im)) + call max_fields(Statein%phil,Diag%refl_10cm,con_g,im,levs,refd,Stateout%gt0,refd263k) + if (reset) then + do i=1,im + Diag%refdmax(I) = -35. + Diag%refdmax263k(I) = -35. + enddo + endif do i=1,im - Diag%refdmax(I) = -35. - Diag%refdmax263k(I) = -35. + Diag%refdmax(i) = max(Diag%refdmax(i),refd(i)) + Diag%refdmax263k(i) = max(Diag%refdmax263k(i),refd263k(i)) enddo + deallocate (refd) + deallocate (refd263k) endif - do i=1,im - Diag%refdmax(i) = max(Diag%refdmax(i),refd(i)) - Diag%refdmax263k(i) = max(Diag%refdmax263k(i),refd263k(i)) - enddo - deallocate (refd) - deallocate (refd263k) - endif ! if(Model%effr_in) then call cloud_diagnosis (1, im, 1, levs, den(1:im,1:levs), & @@ -4922,22 +4967,22 @@ subroutine GFS_physics_driver & Tbd%phy_f3d(1:im,1:levs,3), Tbd%phy_f3d(1:im,1:levs,4), & Tbd%phy_f3d(1:im,1:levs,5)) -! do k = 1, levs -! do i=1,im +! do k = 1, levs +! do i=1,im ! -! if(Model%me==0) then -! if(Tbd%phy_f3d(i,k,1) > 5.) then -! write(6,*) 'phy driver:cloud radii:',Model%kdt, i,k, & -! Tbd%phy_f3d(i,k,1) -! endif -! if(Tbd%phy_f3d(i,k,3)> zero) then -! write(6,*) 'phy driver:rain radii:',Model%kdt, i,k, & -! Tbd%phy_f3d(i,k,3) -! endif -! -! endif -! enddo -! enddo +! if(Model%me==0) then +! if(Tbd%phy_f3d(i,k,1) > 5.) then +! write(6,*) 'phy driver:cloud radii:',Model%kdt, i,k, & +! Tbd%phy_f3d(i,k,1) +! endif +! if(Tbd%phy_f3d(i,k,3)> zero) then +! write(6,*) 'phy driver:rain radii:',Model%kdt, i,k, & +! Tbd%phy_f3d(i,k,3) +! endif +! +! endif +! enddo +! enddo endif @@ -4995,7 +5040,7 @@ subroutine GFS_physics_driver & enddo endif - Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) + Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) ! total rain per timestep if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm ! @@ -5124,6 +5169,7 @@ subroutine GFS_physics_driver & enddo elseif( .not. Model%cal_pre) then if (Model%imp_physics == Model%imp_physics_mg) then ! MG microphysics + tem = con_day / (dtp * con_p001) ! mm / day do i=1,im Sfcprop%tprcp(i) = max(zero, Diag%rain(i) ) ! clu: rain -> tprcp if (Diag%rain(i)*tem > rainmin) then @@ -5277,7 +5323,15 @@ subroutine GFS_physics_driver & ! &' rain=',rain(ipr),' rainc=',rainc(ipr) ! if (lprnt) call mpi_quit(7) ! if (kdt > 2 ) call mpi_quit(70) -! if (lprnt) write(0,*)'qt0out=',Stateout%gt0(ipr,:) & +! if (lprnt) then +! write(0,*)' at the end of physics kdt=',kdt +! write(0,*)' end rain=',diag%rain(ipr),' rainc=',diag%rainc(ipr) +! write(0,*)'qt0out=',Stateout%gt0(ipr,:) +! write(0,*)'qq0outv=',Stateout%gq0(ipr,:,1) +! write(0,*)'qq0outw=',Stateout%gq0(ipr,:,ntcw) +! write(0,*)'qq0outi=',Stateout%gq0(ipr,:,ntiw) +! write(0,*)'qq0outo=',Stateout%gq0(ipr,:,ntoz) +! endif ! if (lprnt) write(0,*)'gq0outtke=',Stateout%gq0(ipr,1:25,ntke) & ! ,'xlon=',grid%xlon(ipr)*rad2dg,' xlat=',grid%xlat(ipr)*rad2dg ! if (lprnt) write(0,*)' clouddriverend=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index ec8be1620..143d91dfc 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -659,9 +659,7 @@ module GFS_typedefs real(kind=kind_phys) :: mg_dcs !< Morrison-Gettelman microphysics parameters real(kind=kind_phys) :: mg_qcvar real(kind=kind_phys) :: mg_ts_auto_ice(2) !< ice auto conversion time scale -#ifdef CCPP real(kind=kind_phys) :: mg_rhmini !< relative humidity threshold parameter for nucleating ice -#endif real(kind=kind_phys) :: mg_ncnst !< constant droplet num concentration (m-3) real(kind=kind_phys) :: mg_ninst !< constant ice num concentration (m-3) @@ -670,11 +668,9 @@ module GFS_typedefs real(kind=kind_phys) :: mg_alf !< tuning factor for alphs in MG macrophysics real(kind=kind_phys) :: mg_qcmin(2) !< min liquid and ice mixing ratio in Mg macro clouds character(len=16) :: mg_precip_frac_method ! type of precipitation fraction method -#ifdef CCPP real(kind=kind_phys) :: tf real(kind=kind_phys) :: tcr real(kind=kind_phys) :: tcrf -#endif ! logical :: effr_in !< eg to turn on ffective radii for MG logical :: microp_uniform @@ -2579,18 +2575,16 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- modules #ifdef CCPP use physcons, only: con_rerth, con_pi +! use rascnv, only: nrcmax #else use physcons, only: dxmax, dxmin, dxinv, con_rerth, con_pi, rhc_max -#endif - use mersenne_twister, only: random_setseed, random_number -#ifndef CCPP use module_ras, only: nrcmax -#endif - use parse_tracers, only: get_tracer_index -#ifndef CCPP use wam_f107_kp_mod, only: f107_kp_size, f107_kp_interval, & f107_kp_skip_size, f107_kp_data_size #endif + use mersenne_twister, only: random_setseed, random_number + use parse_tracers, only: get_tracer_index +! implicit none !--- interface variables @@ -2711,9 +2705,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: mg_dcs = 200.0 !< Morrison-Gettelman microphysics parameters real(kind=kind_phys) :: mg_qcvar = 1.0 real(kind=kind_phys) :: mg_ts_auto_ice(2) = (/180.0,180.0/) !< ice auto conversion time scale -#ifdef CCPP real(kind=kind_phys) :: mg_rhmini = 1.01 !< relative humidity threshold parameter for nucleating ice -#endif real(kind=kind_phys) :: mg_ncnst = 100.e6 !< constant droplet num concentration (m-3) real(kind=kind_phys) :: mg_ninst = 0.15e6 !< constant ice num concentration (m-3) real(kind=kind_phys) :: mg_ngnst = 0.10e6 !< constant graupel/hail num concentration (m-3) = 0.1e6_r8 @@ -2721,10 +2713,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: mg_qcmin(2) = (/1.0d-9,1.0d-9/) !< min liquid and ice mixing ratio in Mg macro clouds real(kind=kind_phys) :: mg_berg_eff_factor = 2.0 !< berg efficiency factor character(len=16) :: mg_precip_frac_method = 'max_overlap' !< type of precipitation fraction method -#ifdef CCPP real(kind=kind_phys) :: tf = 258.16d0 real(kind=kind_phys) :: tcr = 273.16d0 -#endif ! logical :: effr_in = .false. !< flag to use effective radii of cloud species in radiation logical :: microp_uniform = .true. @@ -2886,6 +2876,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: psauras(2) = (/1.0d-3,1.0d-3/) !< [in] auto conversion coeff from ice to snow in ras real(kind=kind_phys) :: prauras(2) = (/2.0d-3,2.0d-3/) !< [in] auto conversion coeff from cloud to rain in ras real(kind=kind_phys) :: wminras(2) = (/1.0d-5,1.0d-5/) !< [in] water and ice minimum threshold for ras +#ifdef CCPP + integer :: nrcmax = 32 !< number of random numbers used in RAS +#endif real(kind=kind_phys) :: rbcr = 0.25 !< Critical Richardson Number in PBL scheme real(kind=kind_phys) :: shoc_parm(5) = (/7000.0,1.0,4.2857143,0.7,-999.0/) !< some tunable parameters for shoc @@ -3024,12 +3017,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & iccn, & !--- microphysical parameterizations ncld, imp_physics, psautco, prautco, evpco, wminco, & -#ifdef CCPP fprcp, pdfflag, mg_dcs, mg_qcvar, mg_ts_auto_ice, mg_rhmini, & effr_in, tf, tcr, & -#else - fprcp, pdfflag, mg_dcs, mg_qcvar, mg_ts_auto_ice, effr_in, & -#endif microp_uniform, do_cldice, hetfrz_classnuc, & mg_do_graupel, mg_do_hail, mg_nccons, mg_nicons, mg_ngcons, & mg_ncnst, mg_ninst, mg_ngnst, sed_supersat, do_sb_physics, & @@ -3289,9 +3278,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%mg_dcs = mg_dcs Model%mg_qcvar = mg_qcvar Model%mg_ts_auto_ice = mg_ts_auto_ice -#ifdef CCPP Model%mg_rhmini = mg_rhmini -#endif Model%mg_alf = mg_alf Model%mg_qcmin = mg_qcmin Model%effr_in = effr_in @@ -3312,11 +3299,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%do_sb_physics = do_sb_physics Model%mg_precip_frac_method = mg_precip_frac_method Model%mg_berg_eff_factor = mg_berg_eff_factor -#ifdef CCPP Model%tf = tf Model%tcr = tcr Model%tcrf = 1.0/(tcr-tf) -#endif !--- Thompson MP parameters Model%ltaerosol = ltaerosol @@ -3381,12 +3366,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%do_aw = do_aw Model%cs_parm = cs_parm Model%do_shoc = do_shoc -#ifdef CCPP - if (Model%do_shoc) then - print *, "Error, update of SHOC from May 22 2019 not yet in CCPP" - stop - end if -#endif +!#ifdef CCPP +! if (Model%do_shoc) then +! print *, "Error, update of SHOC from May 22 2019 not yet in CCPP" +! stop +! end if +!#endif Model%shoc_parm = shoc_parm Model%shocaftcnv = shocaftcnv Model%shoc_cld = shoc_cld @@ -3443,7 +3428,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%wminras = wminras Model%rbcr = rbcr Model%do_gwd = maxval(Model%cdmbgwd) > 0.0 - Model%do_cnvgwd = Model%cnvgwd .and. maxval(Model%cdmbgwd(3:4)) == 0.0 + + Model%do_cnvgwd = Model%cnvgwd .and. (maxval(Model%cdmbgwd(3:4)) == 0.0 .and. .not. Model%do_ugwp) #ifdef CCPP Model%do_mynnedmf = do_mynnedmf Model%do_mynnsfclay = do_mynnsfclay @@ -3759,15 +3745,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- set nrcm -#ifndef CCPP +!#ifndef CCPP if (Model%ras) then Model%nrcm = min(nrcmax, Model%levs-1) * (Model%dtp/1200.d0) + 0.10001d0 else Model%nrcm = 2 endif -#else - Model%nrcm = 2 -#endif +!#else +! Model%nrcm = 2 +!#endif !--- cal_pre if (Model%cal_pre) then @@ -3981,7 +3967,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' do_gwd=',Model%do_gwd endif if (Model%do_cnvgwd) then - print *,' Convective GWD parameterization used, do_cnvgwd=',do_cnvgwd + print *,' Convective GWD parameterization used, do_cnvgwd=',Model%do_cnvgwd endif if (Model%crick_proof) print *,' CRICK-Proof cloud water used in radiation ' if (Model%ccnorm) print *,' Cloud condensate normalized by cloud cover for radiation' @@ -4340,6 +4326,7 @@ subroutine control_print(Model) print *, ' mg_ts_auto_ice : ', Model%mg_ts_auto_ice print *, ' mg_alf : ', Model%mg_alf print *, ' mg_qcmin : ', Model%mg_qcmin + print *, ' mg_rhmini : ', Model%mg_rhmini print *, ' pdfflag : ', Model%pdfflag print *, ' ' endif @@ -5280,8 +5267,8 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%u10max = zero Diag%v10max = zero Diag%spd10max = zero - Diag%rain = zero - Diag%rainc = zero +! Diag%rain = zero +! Diag%rainc = zero Diag%ice = zero Diag%snow = zero Diag%graupel = zero @@ -5999,6 +5986,7 @@ subroutine interstitial_setup_tracers(Interstitial, Model) do n=2,Model%ntrac if ( n /= Model%ntcw .and. n /= Model%ntiw .and. n /= Model%ntclamt .and. & n /= Model%ntrw .and. n /= Model%ntsw .and. n /= Model%ntrnc .and. & + n /= Model%ntlnc .and. n /= Model%ntinc .and. & n /= Model%ntsnc .and. n /= Model%ntgl .and. n /= Model%ntgnc) then tracers = tracers + 1 if (Model%ntke == n ) then @@ -6014,7 +6002,8 @@ subroutine interstitial_setup_tracers(Interstitial, Model) enddo Interstitial%tracers_total = tracers - 2 endif ! end if_ras or cfscnv or samf - if(.not. Model%satmedmf .and. .not. Model%trans_trac) then + if (.not. Model%satmedmf .and. .not. Model%trans_trac .and. & + .not. Model%ras .and. .not. Model%do_shoc) then Interstitial%nsamftrac = 0 else Interstitial%nsamftrac = Interstitial%tracers_total @@ -6169,9 +6158,9 @@ subroutine interstitial_phys_reset (Interstitial, Model) Interstitial%gamq = clear_val Interstitial%gamt = clear_val Interstitial%gflx = clear_val - Interstitial%gflx_ice = zero - Interstitial%gflx_land = zero - Interstitial%gflx_ocean = zero + Interstitial%gflx_ice = clear_val + Interstitial%gflx_land = clear_val + Interstitial%gflx_ocean = clear_val Interstitial%gwdcu = clear_val Interstitial%gwdcv = clear_val Interstitial%hflx = clear_val diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index fbe232e52..2154aa5bb 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -1948,6 +1948,12 @@ units = flag dimensions = () type = logical +[cplwav2atm] + standard_name = flag_for_wave_coupling_to_atm + long_name = flag controlling ocean wave coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical [cplchm] standard_name = flag_for_chemistry_coupling long_name = flag controlling cplchm collection (default off) diff --git a/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 index ff9391db1..4693131ac 100644 --- a/gfsphysics/physics/gcm_shoc.f90 +++ b/gfsphysics/physics/gcm_shoc.f90 @@ -92,12 +92,12 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & real, intent(inout) :: ncpl (nx,nzm) ! cloud water number concentration,/m^3 real, intent(inout) :: ncpi (nx,nzm) ! cloud ice number concentration,/m^3 - real, intent(inout) :: qpl (nx,nzm) ! rain mixing ratio, kg/kg - real, intent(inout) :: qpi (nx,nzm) ! snow mixing ratio, kg/kg + real, intent(in) :: qpl (nx,nzm) ! rain mixing ratio, kg/kg + real, intent(in) :: qpi (nx,nzm) ! snow mixing ratio, kg/kg real, intent(inout) :: rhc (nx,nzm) ! critical relative humidity real, intent(in) :: supice ! ice supersaturation parameter - real, intent(inout) :: cld_sgs(ix,nzm) ! sgs cloud fraction + real, intent(out) :: cld_sgs(ix,nzm) ! sgs cloud fraction ! real, intent(inout) :: cld_sgs(nx,nzm) ! sgs cloud fraction real, intent(inout) :: tke (ix,nzm) ! turbulent kinetic energy. m**2/s**2 ! real, intent(inout) :: tk (nx,nzm) ! eddy viscosity @@ -176,8 +176,6 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & real w (nx,nzm) ! z-wind, m/s real bet (nx,nzm) ! ggr/tv0 real gamaz (nx,nzm) ! ggr/cp*z -! real qpi (nx,nzm) ! snow + graupel mixing ratio, kg/kg -! real qpl (nx,nzm) ! rain mixing ratio, kg/kg ! Moments of the trivariate double Gaussian PDF for the SGS total water mixing ratio ! SGS liquid/ice static energy, and vertical velocity @@ -256,12 +254,13 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & enddo enddo -! if (lprnt) write(0,*)' tabsin=',tabs(ipr,1,1:40) -! if (lprnt) write(0,*)' qcin=',qc(ipr,1,1:40) -! if (lprnt) write(0,*)' qwvin=',qwv(ipr,1,1:40) -! if (lprnt) write(0,*)' qiin=',qi(ipr,1,1:40) -! if (lprnt) write(0,*)' qplin=',qpl(ipr,1,1:40) -! if (lprnt) write(0,*)' qpiin=',qpi(ipr,1,1:40) +! if (lprnt) write(0,*)' tabsin=',tabs(ipr,:) +! if (lprnt) write(0,*)' qcin=',qc(ipr,:) +! if (lprnt) write(0,*)' qwvin=',qwv(ipr,:) +! if (lprnt) write(0,*)' qiin=',qi(ipr,:) +! if (lprnt) write(0,*)' qplin=',qpl(ipr,:) +! if (lprnt) write(0,*)' qpiin=',qpi(ipr,:) +! if (lprnt) write(0,*)' tkein=',tke(ipr,:) ! ! move water from vapor to condensate if the condensate is negative ! @@ -289,7 +288,8 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & enddo enddo -! if (lprnt) write(0,*)' tabsin2=',tabs(ipr,1,1:40) +! if (lprnt) write(0,*)' tabsin2=',tabs(ipr,:) +! if (lprnt) write(0,*)' qwvin2=',qwv(ipr,:) do k=1,nzm do i=1,nx @@ -318,11 +318,15 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & ! Liquid/ice water static energy - ! Note the the units are degrees K hl(i,k) = tabs(i,k) + gamaz(i,k) - fac_cond*(qcl(i,k)+qpl(i,k)) & - fac_sub *(qci(i,k)+qpi(i,k)) +! if (lprnt .and. i == ipr .and. k<=10) write(0,*)' hl=',hl(i,k), & +! ' tabs=',tabs(i,k),' gamaz=',gamaz(i,k), ' fac_cond=',fac_cond, & +! ' qcl=',qcl(i,k),' qpl=',qpl(i,k),' qci=',qci(i,k),' qpi=',qpi(i,k),& +! ' fac_sub=',fac_sub,' k=',k w3(i,k) = zero enddo enddo -! if (lprnt) write(0,*)' hlin=',hl(ipr,1,1:40) +! if (lprnt) write(0,*)' hlin=',hl(ipr,1:40) ! Define vertical grid increments for later use in the vertical differentiation @@ -445,6 +449,11 @@ subroutine shoc(ix, nx, nzm, nz, dtn, me, lat, & call assumed_pdf() +! if (lprnt) write(0,*)' tabsout=',tabs(ipr,1:40) +! if (lprnt) write(0,*)' qcout=',qc(ipr,1:40) +! if (lprnt) write(0,*)' qwvout=',qwv(ipr,1:40) +! if (lprnt) write(0,*)' qiout=',qi(ipr,1:40) + contains subroutine tke_shoc() @@ -586,6 +595,8 @@ subroutine tke_shoc() isotropy(i,k) = min(max_eddy_dissipation_time_scale, & tscale1/(one+lambda*buoy_sgs*tscale1*tscale1)) endif +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' isotropy=',isotropy(i,k),& +! ' buoy_sgs=',buoy_sgs,' lambda=',lambda,' tscale1=',tscale1 ! TKE budget terms @@ -605,6 +616,8 @@ subroutine tke_shoc() tkh(i,k) = min(tkhmax, wrk * (isotropy(i,k) * tke(i,k) & + isotropy(i,k1) * tke(i,k1))) ! Eddy thermal diffusivity enddo ! i +! if (lprnt) write(0,*)' shocendtkh=',tkh(ipr,k),' tke=',tke(ipr,k),& +! tke(ipr,k1),' isot=',isotropy(ipr,k),isotropy(ipr,k1),'k=',k,' k1=',k1 enddo ! k @@ -985,8 +998,8 @@ subroutine canuto() real bet2, f0, f1, f2, f3, f4, f5, iso, isosqr, & omega0, omega1, omega2, X0, Y0, X1, Y1, AA0, AA1, buoy_sgs2, & -! wrk, wrk1, wrk2, wrk3, avew - cond_w, wrk, wrk1, wrk2, wrk3, avew + wrk, wrk1, wrk2, wrk3, avew +! cond_w, wrk, wrk1, wrk2, wrk3, avew ! ! See Eq. 7 in C01 (B.7 in Pete's dissertation) real, parameter :: c=7.0d0, a0=0.52d0/(c*c*(c-2.0d0)), a1=0.87d0/(c*c), & @@ -1040,8 +1053,7 @@ subroutine canuto() ! This is not a bug, but an algorithmical change. ! The line below calculates cond_w ,an estimate of the maximum allowed value of the third moment. ! It is used at the end of this subroutine to limit the value of w3. -! Here the second moment is interpolated from the layer centers to the interface, where w3 is -! defined. +! Here the second moment is interpolated from the layer centers to the interface, where w3 is defined. ! In the presence of strong vertical gradients of w2, the value interpolated to the interface can ! be as much as twice as as large (or as small) as the value on in layer center. When the skewness ! of W PDF is calculated in assumed_pdf(), the code there uses w2 on the layer center, and the value @@ -1328,6 +1340,9 @@ subroutine assumed_pdf() qw1_1 = - corrtest2 / w1_2 ! A.7 qw1_2 = - corrtest2 / w1_1 ! A.8 +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' qw1_1=',qw1_1,' corrtest2=',corrtest2,& +! ' w1_2=',w1_2,' wqwsec=',wqwsec,' sqrtw2=',sqrtw2,' sqrtqt=',sqrtqt,' qwsec=',qwsec + tsign = abs(qw1_2-qw1_1) ! Skew_qw = skew_facw*Skew_w @@ -1397,6 +1412,7 @@ subroutine assumed_pdf() IF (Tl1_1 >= tbgmax) THEN lstarn1 = lcond esval = min(fpvsl(Tl1_1), pval) +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' esval=',esval,' pval=',pval,' eps=',eps qs1 = eps * esval / (pval-0.378d0*esval) ELSE IF (Tl1_1 <= tbgmin) THEN lstarn1 = lsub @@ -1460,6 +1476,9 @@ subroutine assumed_pdf() s1 = qw1_1 - wrk ! A.17 cthl1 = cqt1*wrk*cpolv*beta1*pkap ! A.20 +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc s1=',s1,' qw1_1=',qw1_1,'wrk=',wrk,& +! ' qs1=',qs1,' beta1=',beta1,' cqt1=',cqt1 + wrk1 = cthl1 * cthl1 wrk2 = cqt1 * cqt1 ! std_s1 = sqrt(max(zero,wrk1*thl2_1+wrk2*qw2_1-2.*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) @@ -1473,13 +1492,13 @@ subroutine assumed_pdf() wrk = s1 / (std_s1*sqrt2) C1 = max(zero, min(one, half*(one+erf(wrk)))) ! A.15 -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc wrk=',wrk,' s1=','std=',std_s1,& +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc wrk=',wrk,' s1=',s1,'std=',std_s1,& ! ' c1=',c1*100,' qs1=',qs1,' qw1_1=',qw1_1,' k=',k IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 - ELSEIF (s1 >= qcmin) THEN - C1 = one - qn1 = s1 +!! ELSEIF (s1 >= qcmin) THEN +!! C1 = one +!! qn1 = s1 ENDIF ! now compute non-precipitating cloud condensate @@ -1512,9 +1531,9 @@ subroutine assumed_pdf() wrk = s2 / (std_s2*sqrt2) C2 = max(zero, min(one, half*(one+erf(wrk)))) IF (C2 > zero) qn2 = s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk) - ELSEIF (s2 >= qcmin) THEN - C2 = one - qn2 = s2 +!! ELSEIF (s2 >= qcmin) THEN +!! C2 = one +!! qn2 = s2 ENDIF ENDIF @@ -1551,7 +1570,7 @@ subroutine assumed_pdf() + fac_sub *(diag_qi+qpi(i,k)) & + tkesbdiss(i,k) * (dtn/cp) ! tke dissipative heating -! if (lprnt .and. i == ipr .and. k < 40) write(0,*)' tabsout=',tabs(ipr,1,k),' k=',k& +! if (lprnt .and. i == ipr .and. k < 40) write(0,*)' tabsout=',tabs(ipr,k),' k=',k& ! ,' hl=',hl(i,k),' gamaz=',gamaz(i,k),' diag_ql=',diag_ql,' qpl=',qpl(i,k)& ! ,' diag_qi=',diag_qi,' qpi=',qpi(i,k),' diag_qn =',diag_qn ,' aterm=',aterm,' onema=',onema& ! ,' qn1=',qn1 ,' qn2=',qn2,' ql1=',ql1,' ql2=',ql2 diff --git a/gfsphysics/physics/m_micro_driver.F90 b/gfsphysics/physics/m_micro_driver.F90 index 9d4d3a318..9d6e8be7a 100644 --- a/gfsphysics/physics/m_micro_driver.F90 +++ b/gfsphysics/physics/m_micro_driver.F90 @@ -3,7 +3,6 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & &, omega_i, QLLS_i, QLCN_i, QILS_i, QICN_i& &, lwheat_i, swheat_i, w_upi, cf_upi & &, FRLAND, ZPBL, CNV_MFD_i & -! &, FRLAND, ZPBL, CNV_MFD_i, CNV_PRC3_i & &, CNV_DQLDT_i, CLCN_i, u_i, v_i & &, TAUGWX, TAUGWY, TAUX, TAUY & &, TAUOROX, TAUOROY, CNV_FICE_i & @@ -16,7 +15,6 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & &, CLDREFFG, aerfld_i & &, aero_in, naai_i, npccn_i, iccn & &, skip_macro & -! &, skip_macro, cn_prc2, cn_snr & &, lprnt, alf_fac, qc_min, pdfflag & &, ipr, kdt, xlat, xlon, rhc_i) @@ -73,20 +71,20 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & real (kind=kind_phys), dimension(im,lm),intent(in) :: & & CNV_DQLDT_i, CLCN_i, QLCN_i, QICN_i, & & CNV_MFD_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & -! & CNV_MFD_i, CNV_PRC3_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & & CNV_NICE_i, w_upi, rhc_i, naai_i, npccn_i real (kind=kind_phys), dimension(im,lm,ntrcaer),intent(in) :: & & aerfld_i real (kind=kind_phys),dimension(im),intent(in):: TAUGWX, & & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY, FRLAND,ZPBL,xlat,xlon -! & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY,ps_i,FRLAND,ZPBL -! & CNVPRCP ! output real (kind=kind_phys),dimension(ix,lm) :: lwm_o, qi_o, & cldreffl, cldreffi, cldreffr, cldreffs, cldreffg real (kind=kind_phys),dimension(im) :: rn_o, sr_o +! Anning Cheng 10/24/2016 twat for total water, diagnostic purpose + integer, dimension(IM) :: KCBL + ! input and output real (kind=kind_phys),dimension(ix,lm),intent(inout):: q_io, t_io, & & ncpl_io,ncpi_io,CLLS_io @@ -170,8 +168,6 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! & LS_SNR, LS_PRC2, TPREC real(kind=kind_phys), dimension(IM) :: LS_SNR, LS_PRC2 ! & VMIP, twat -! Anning Cheng 10/24/2016 twat for total water, diagnostic purpose - integer, dimension(IM) :: KCBL real(kind=kind_phys), dimension (LM) :: uwind_gw,vwind_gw, & & tm_gw, pm_gw, nm_gw, h_gw, rho_gw, khaux, qcaux, & @@ -393,6 +389,13 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & enddo endif endif + +! if (lprnt) then +! write(0,*)' inmic qlcn=',qlcn(ipr,:) +! write(0,*)' inmic qlls=',qlls(ipr,:) +! write(0,*)' inmic qicn=',qicn(ipr,:) +! write(0,*)' inmic qils=',qils(ipr,:) +! endif ! DT_MOIST = dt_i dt_r8 = dt_i @@ -1399,7 +1402,9 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! if(lprint) then ! write(0,*)' calling micro_mg_tend3_0 qcvar3=',qcvar3,' i=',i ! write(0,*)' qcr8=',qcr8(:) +! write(0,*)' qir8=',qir8(:) ! write(0,*)' ncr8=',ncr8(:) +! write(0,*)' nir8=',nir8(:) ! write(0,*)' npccninr8=',npccninr8(:) ! write(0,*)' plevr8=',plevr8(:) ! write(0,*)' ter8=',ter8(:) @@ -1535,10 +1540,18 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & if (skip_macro) then do k=1,lm do i=1,im + QLCN(i,k) = QL_TOT(i,k) * FQA(i,k) + QLLS(i,k) = QL_TOT(i,k) - QLCN(i,k) + QICN(i,k) = QI_TOT(i,k) * FQA(i,k) + QILS(i,k) = QI_TOT(i,k) - QICN(i,k) + CALL fix_up_clouds_2M(Q1(I,K), TEMP(i,k), QLLS(I,K), & & QILS(I,K), CLLS(I,K), QLCN(I,K), & & QICN(I,K), CLCN(I,K), NCPL(I,K), & & NCPI(I,K), qc_min) + + QL_TOT(I,K) = QLLS(I,K) + QLCN(I,K) + QI_TOT(I,K) = QILS(I,K) + QICN(I,K) if (rnw(i,k) <= qc_min(1)) then ncpl(i,k) = 0.0 elseif (ncpl(i,k) <= nmin) then ! make sure NL > 0 if Q >0 @@ -1695,7 +1708,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & if (allocated(ALPHT_X)) deallocate (ALPHT_X) ! if (lprnt) then -! write(0,*)' rn_o=',rn_o(ipr),' ls_prc2=',ls_prc2(ipr),' ls_snr=',ls_snr(ipr) +! write(0,*)' rn_o=',rn_o(ipr),' ls_prc2=',ls_prc2(ipr),' ls_snr=',ls_snr(ipr),' kdt=',kdt ! write(0,*)' end micro_mg_tend t_io= ', t_io(ipr,:) ! write(0,*)' end micro_mg_tend clls_io= ', clls_io(ipr,:) ! endif diff --git a/gfsphysics/physics/micro_mg2_0.F90 b/gfsphysics/physics/micro_mg2_0.F90 index 325a2dbbe..281802878 100644 --- a/gfsphysics/physics/micro_mg2_0.F90 +++ b/gfsphysics/physics/micro_mg2_0.F90 @@ -1,44 +1,27 @@ +!>\file micro_mg2_0.F90 +!! This file contains Morrison-Gettelman MP version 2.0 - update of MG +!! microphysics with prognostic precipitation. + +!>\ingroup mg2mg3 +!>\defgroup mg2_0_mp Morrison-Gettelman MP version 2.0 +!! This module includes the MG microphysics version 2.0 - update of MG +!! microphysics with prognostic precipitation. +!! +!!\author Andrew Gettelman, Hugh Morrison, Sean Santos +!! e-mail: morrison@ucar.edu, andrew@ucar.edu +!!\n Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan +!! +!! - Anning Cheng adopted for FV3GFS 9/29/2017 +!! - Anning Cheng added GMAO ice conversion and Liu et al. Liquid water conversion +!! in 10/12/2017 +!! - S. Moorthi - Oct/Nov 2017 - optimized the code +!! - S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit +!! - Version 2 history: +!! - Sep 2011: Development begun +!! - Feb 2013: Added of prognostic precipitation +!! - Aug 2015: Published and released version (\cite Gettelman_2015_1 \cite Gettelman_2015_2 ) module micro_mg2_0 !--------------------------------------------------------------------------------- -! Purpose: -! MG microphysics version 2.0 - Update of MG microphysics with -! prognostic precipitation. -! -! Author: Andrew Gettelman, Hugh Morrison, Sean Santos -! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan -! Anning Cheng adopted for FV3GFS 9/29/2017 -! add GMAO ice conversion and Liu et. al liquid water -! conversion in 10/12/2017 -! Anning showed promising results for FV3GFS on 10/15/2017 -! S. Moorthi - Oct/Nov 2017 - optimized the code -! S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit -! Version 2 history: Sep 2011: Development begun. -! Feb 2013: Added of prognostic precipitation. -! Aug 2015: Published and released version -! -! invoked in CAM by specifying -microphys=mg2.0 -! -! References: -! -! Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. -! -! Part I: Off line tests and comparisons with other schemes. -! -! J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. -! -! -! -! Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell -! -! Advanced Two-Moment Microphysics for Global Models. -! -! Part II: Global model solutions and Aerosol-Cloud Interactions. -! -! J. Climate, 28, 1288-1307. doi:10.1175/JCLI-D-14-00103.1 , 2015. -! -! for questions contact Hugh Morrison, Andrew Gettelman -! e-mail: morrison@ucar.edu, andrew@ucar.edu -!--------------------------------------------------------------------------------- ! ! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice ! microphysics in cooperation with the MG liquid microphysics. This is @@ -214,6 +197,8 @@ module micro_mg2_0 contains !=============================================================================== +!>\ingroup mg2_0_mp +!! This subroutine calculates subroutine micro_mg_init( & kind, gravit, rair, rh2o, cpair, & tmelt_in, latvap, latice, & @@ -236,29 +221,29 @@ subroutine micro_mg_init( & ! !----------------------------------------------------------------------- - integer, intent(in) :: kind ! Kind used for reals + integer, intent(in) :: kind !< Kind used for reals real(r8), intent(in) :: gravit real(r8), intent(in) :: rair real(r8), intent(in) :: rh2o real(r8), intent(in) :: cpair - real(r8), intent(in) :: tmelt_in ! Freezing point of water (K) + real(r8), intent(in) :: tmelt_in !< Freezing point of water (K) real(r8), intent(in) :: latvap real(r8), intent(in) :: latice - real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. + real(r8), intent(in) :: rhmini_in !< Minimum rh for ice cloud fraction > 0. real(r8), intent(in) :: micro_mg_dcs real(r8), intent(in) :: ts_auto(2) real(r8), intent(in) :: mg_qcvar - logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns - ! .false. = use w/o sub-columns (standard) - logical, intent(in) :: do_cldice_in ! .true. = do all processes (standard) - ! .false. = skip all processes affecting cloud ice - logical, intent(in) :: use_hetfrz_classnuc_in ! use heterogeneous freezing + logical, intent(in) :: microp_uniform_in !< .true. = configure uniform for sub-columns + !! .false. = use w/o sub-columns (standard) + logical, intent(in) :: do_cldice_in !< .true. = do all processes (standard) + !! .false. = skip all processes affecting cloud ice + logical, intent(in) :: use_hetfrz_classnuc_in !< use heterogeneous freezing - character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method - real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor - logical, intent(in) :: allow_sed_supersat_in ! allow supersaturated conditions after sedimentation loop - logical, intent(in) :: do_sb_physics_in ! do SB autoconversion and accretion physics + character(len=16),intent(in) :: micro_mg_precip_frac_method_in !< type of precipitation fraction method + real(r8), intent(in) :: micro_mg_berg_eff_factor_in !< berg efficiency factor + logical, intent(in) :: allow_sed_supersat_in !< allow supersaturated conditions after sedimentation loop + logical, intent(in) :: do_sb_physics_in !< do SB autoconversion and accretion physics logical, intent(in) :: do_ice_gmao_in logical, intent(in) :: do_liq_liu_in @@ -351,6 +336,11 @@ end subroutine micro_mg_init !=============================================================================== !microphysics routine for each timestep goes here... +!\ingroup mg2_0_mp +!> This subroutine is the main microphysics routine to be called each time step +!! +!! this also calls several smaller subroutines to calculate +!! microphysical processes and other utilities subroutine micro_mg_tend ( & mgncol, nlev, deltatin, & t, q, & @@ -3354,6 +3344,8 @@ end subroutine micro_mg_tend !OUTPUT CALCULATIONS !======================================================================== +!>\ingroup mg2_0_mp +!! This subroutine subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol,nlev) integer, intent(in) :: mgncol, nlev real(r8), dimension(mgncol,nlev), intent(in) :: lamr ! rain size parameter (slope) diff --git a/gfsphysics/physics/micro_mg3_0.F90 b/gfsphysics/physics/micro_mg3_0.F90 index cbd25370a..f27aa1896 100644 --- a/gfsphysics/physics/micro_mg3_0.F90 +++ b/gfsphysics/physics/micro_mg3_0.F90 @@ -1601,7 +1601,7 @@ subroutine micro_mg_tend ( & tlat(i,k) = tlat(i,k) + dum1 meltsdttot(i,k) = meltsdttot(i,k) + dum1 -! if (lprnt .and. k >=100) write(0,*)' tlats=',tlat(i,k),' dum1=',dum1,& +! if (lprnt .and. k >=40) write(0,*)' tlats=',tlat(i,k),' dum1=',dum1,& ! ' minstsm=',minstsm(i,k),' qs=',qs(i,k),' xlf=',xlf,' oneodt=',oneodt, & ! ' snowmelt=',snowmelt,' t=',t(i,k),' dum=',dum,' k=',k @@ -1643,7 +1643,7 @@ subroutine micro_mg_tend ( & tlat(i,k) = dum1 + tlat(i,k) meltsdttot(i,k) = dum1 + meltsdttot(i,k) -! if (lprnt .and. k >=100) write(0,*)' tlatg=',tlat(i,k),' dum1=',dum1,& +! if (lprnt .and. k >=40) write(0,*)' tlatg=',tlat(i,k),' dum1=',dum1,& ! ' minstgm=',minstgm(i,k),' qg=',qg(i,k),' xlf=',xlf,' oneodt=',oneodt, & ! ' snowmelt=',snowmelt,' t=',t(i,k),' k=',k,' cpp=',cpp @@ -2171,6 +2171,10 @@ subroutine micro_mg_tend ( & call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & bergs(:,k), mgncol) +! if(lprnt) write(0,*)' bergs1=',bergs(1,k),' k=',k,' micro_mg_berg_eff_factor=',micro_mg_berg_eff_factor +! if(lprnt) write(0,*)' t=',t(1,k),' rho=',rho(1,k),' dv=',dv(1,k),' mu=',mu(1,k),& +! 'qcic=',qcic(1,k),' qsic=',qsic(1,k),' qvl=',qvl(1,k),' qvi=',qvi(1,k), & +! ' mu=',mu(1,k),' sc=',sc(1,k),' asn=',asn(1,k),' lams=',lams(1,k),' n0s=',n0s(1,k) bergs(:,k) = bergs(:,k) * micro_mg_berg_eff_factor @@ -2181,6 +2185,11 @@ subroutine micro_mg_tend ( & icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & berg(:,k), vap_dep(:,k), ice_sublim(:,k), mgncol) +! if(lprnt) write(0,*)' t=',t(1,k),' k=',k,' q=',q(1,k),' qi=',qi(1,k),& +! ' ni=',ni(1,k),' icldm=',icldm(1,k),' rho=',rho(1,k),' dv=',dv(1,k),& +! ' qvl=',qvl(1,k),' qvi=',qvi(1,k),' berg=',berg(1,k),' vap_dep=',& +! vap_dep(1,k),' ice_sublim=',ice_sublim(1,k) +! if(lprnt) write(0,*)' berg1=',berg(1,k),' k=',k,' micro_mg_berg_eff_factor=',micro_mg_berg_eff_factor do i=1,mgncol ! sublimation should not exceed available ice ice_sublim(i,k) = max(ice_sublim(i,k), -qi(i,k)*oneodt) @@ -2356,6 +2365,8 @@ subroutine micro_mg_tend ( & qcrat(i,k) = one end if +! if(lprnt) write(0,*)' bergs2=',bergs(1,k),' k=',k,' ratio=',ratio + !PMC 12/3/12: ratio is also frac of step w/ liquid. !thus we apply berg for "ratio" of timestep and vapor !deposition for the remaining frac of the timestep. @@ -2827,11 +2838,11 @@ subroutine micro_mg_tend ( & ! if (lprnt) write(0,*)' k=',k,' tlat=',tlat(i,k) ! if (lprnt .and. k >= 60) write(0,*)' k=',k,' tlat=',tlat(i,k) -! qctend(i,k) = qctend(i,k) + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & -! psacws(i,k)-bergs(i,k))*l!ldm(i,k)-berg(i,k) +! qctend(i,k) = qctend(i,k) + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & +! psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) - qctend(i,k) = qctend(i,k)+ & - (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & + qctend(i,k) = qctend(i,k) + & + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k) - & psacws(i,k)-bergs(i,k)-qmultg(i,k)-psacwg(i,k)-pgsacw(i,k))*lcldm(i,k)-berg(i,k) if (do_cldice) then @@ -3669,7 +3680,7 @@ subroutine micro_mg_tend ( & end do !! nstep loop ! if (lprnt) write(0,*)' prectaftssno=',prect(i),' preci=',preci(i) -! if (lprnt) write(0,*)' qgtnd1=',qgtend(1,:) +! if (lprnt) write(0,*)' qgtnd1=',qgtend(1,:) if (do_graupel .or. do_hail) then !++ag Graupel Sedimentation diff --git a/gfsphysics/physics/micro_mg_utils.F90 b/gfsphysics/physics/micro_mg_utils.F90 index e50420270..ab20ec7cf 100644 --- a/gfsphysics/physics/micro_mg_utils.F90 +++ b/gfsphysics/physics/micro_mg_utils.F90 @@ -1,24 +1,30 @@ +!>\file micro_mg_utils.F90 +!! This file contains process rates and utility functions used by the +!! MG microphysics. + +!>\ingroup mg2mg3 +!>\defgroup micro_mg_utils_mod Morrison-Gettelman MP utils Module +!! This module contains process rates and utility functions used by the MG +!! microphysics. +!! +!! Original MG authors: Andrew Gettelman, Hugh Morrison +!! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan +!! +!! Separated from MG 1.5 by B. Eaton. +!! +!! Separated module switched to MG 2.0 and further changes by S. Santos. +!! +!! Anning Cheng changed for FV3GFS 9/29/2017 +!! added ac_time as an input +!! +!! S. Moorthi - Feb 2018 : code optimization +!! +!! This version: https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ +!! +!! for questions contact Hugh Morrison, Andrew Gettelman +!! e-mail: morrison@ucar.edu, andrew@ucar.edu module micro_mg_utils -!-------------------------------------------------------------------------- -! -! This module contains process rates and utility functions used by the MG -! microphysics. -! -! Original MG authors: Andrew Gettelman, Hugh Morrison -! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan -! -! Separated from MG 1.5 by B. Eaton. -! Separated module switched to MG 2.0 and further changes by S. Santos. -! Anning Cheng changed for FV3GFS 9/29/2017 -! added ac_time as an input -! S. Moorthi - Feb 2018 : code optimization -! -! This version: https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ -! -! for questions contact Hugh Morrison, Andrew Gettelman -! e-mail: morrison@ucar.edu, andrew@ucar.edu -! !-------------------------------------------------------------------------- ! ! List of required external functions that must be supplied: @@ -132,25 +138,25 @@ module micro_mg_utils ! Public module parameters (mostly for MG itself) !================================================= -! Pi to 20 digits; more than enough to reach the limit of double precision. +!> Pi to 20 digits; more than enough to reach the limit of double precision. real(r8), parameter, public :: pi = 3.14159265358979323846_r8 -! "One minus small number": number near unity for round-off issues. +!> "One minus small number": number near unity for round-off issues. !real(r8), parameter, public :: omsm = 1._r8 - 1.e-5_r8 real(r8), parameter, public :: omsm = 1._r8 - 1.e-6_r8 -! Smallest mixing ratio considered in microphysics. +!> Smallest mixing ratio considered in microphysics. real(r8), parameter, public :: qsmall = 1.e-18_r8 -! minimum allowed cloud fraction +!> minimum allowed cloud fraction real(r8), parameter, public :: mincld = 0.000001_r8 !real(r8), parameter, public :: mincld = 0.0001_r8 !real(r8), parameter, public :: mincld = 0.0_r8 -real(r8), parameter, public :: rhosn = 250._r8 ! bulk density snow -real(r8), parameter, public :: rhoi = 500._r8 ! bulk density ice -real(r8), parameter, public :: rhow = 1000._r8 ! bulk density liquid -real(r8), parameter, public :: rhows = 917._r8 ! bulk density water solid +real(r8), parameter, public :: rhosn = 250._r8 !< bulk density snow +real(r8), parameter, public :: rhoi = 500._r8 !< bulk density ice +real(r8), parameter, public :: rhow = 1000._r8 !< bulk density liquid +real(r8), parameter, public :: rhows = 917._r8 !< bulk density water solid !++ag !Hail and Graupel (set in MG3) @@ -183,9 +189,9 @@ module micro_mg_utils real(r8), parameter, public :: bh = 0.5_r8 !--ag -! mass of new crystal due to aerosol freezing and growth (kg) -! Make this consistent with the lower bound, to support UTLS and -! stratospheric ice, and the smaller ice size limit. +!> mass of new crystal due to aerosol freezing and growth (kg) +!! Make this consistent with the lower bound, to support UTLS and +!! stratospheric ice, and the smaller ice size limit. real(r8), parameter, public :: mi0 = 4._r8/3._r8*pi*rhoi*(1.e-6_r8)**3 !++ag @@ -284,11 +290,13 @@ module micro_mg_utils ! some argument is an integer. !========================================================= +!>\ingroup micro_mg_utils_mod interface rising_factorial module procedure rising_factorial_r8 module procedure rising_factorial_integer end interface rising_factorial +!>\ingroup micro_mg_utils_mod interface var_coef module procedure var_coef_r8 module procedure var_coef_integer @@ -298,7 +306,8 @@ module micro_mg_utils contains !========================================================================== -! Initialize module variables. +!>\ingroup micro_mg_utils_mod +!! Initialize module variables. ! ! "kind" serves no purpose here except to check for unlikely linking ! issues; always pass in the kind for a double precision real. @@ -372,7 +381,8 @@ subroutine micro_mg_utils_init( kind, rair, rh2o, cpair, tmelt_in, latvap, & end subroutine micro_mg_utils_init -! Constructor for a constituent property object. +!>\ingroup micro_mg_utils_mod +!! Constructor for a constituent property object. function NewMGHydrometeorProps(rho, eff_dim, lambda_bounds, min_mean_mass) & result(res) real(r8), intent(in) :: rho, eff_dim @@ -443,7 +453,8 @@ elemental function calc_ab(t, qv, xxl) result(ab) end function calc_ab -! get cloud droplet size distribution parameters +!>\ingroup micro_mg_utils_mod +!! get cloud droplet size distribution parameters elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc) type(MGHydrometeorProps), intent(in) :: props real(r8), intent(in) :: qcic @@ -512,8 +523,8 @@ elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc end subroutine size_dist_param_liq_line -! get cloud droplet size distribution parameters - +!>\ingroup micro_mg_utils_mod +!! This subroutine gets cloud droplet size distribution parameters subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) type(mghydrometeorprops), intent(in) :: props @@ -587,7 +598,8 @@ subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) end subroutine size_dist_param_liq_vect -! Basic routine for getting size distribution parameters. +!>\ingroup micro_mg_utils_mod +!! Basic routine for getting size distribution parameters. elemental subroutine size_dist_param_basic_line(props, qic, nic, lam, n0) type(MGHydrometeorProps), intent(in) :: props real(r8), intent(in) :: qic @@ -625,6 +637,8 @@ elemental subroutine size_dist_param_basic_line(props, qic, nic, lam, n0) end subroutine size_dist_param_basic_line +!>\ingroup micro_mg_utils_mod +!! This subroutine calculates subroutine size_dist_param_basic_vect(props, qic, nic, lam, mgncol, n0) type (mghydrometeorprops), intent(in) :: props @@ -667,7 +681,8 @@ subroutine size_dist_param_basic_vect(props, qic, nic, lam, mgncol, n0) end subroutine size_dist_param_basic_vect -! ice routine for getting size distribution parameters. +!>\ingroup micro_mg_utils_mod +!! ice routine for getting size distribution parameters. elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) type(MGHydrometeorProps), intent(in) :: props real(r8), intent(in) :: qic @@ -720,6 +735,8 @@ elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) end subroutine size_dist_param_ice_line +!>\ingroup micro_mg_utils_mod +!! This subroutine subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) type (mghydrometeorprops), intent(in) :: props @@ -776,23 +793,24 @@ subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) end subroutine size_dist_param_ice_vect - +!>\ingroup micro_mg_utils_mod +!> Finds the average diameter of particles given their density, and +!! mass/number concentrations in the air. +!! Assumes that diameter follows an exponential distribution. real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) - ! Finds the average diameter of particles given their density, and - ! mass/number concentrations in the air. - ! Assumes that diameter follows an exponential distribution. - real(r8), intent(in) :: q ! mass mixing ratio - real(r8), intent(in) :: n ! number concentration (per volume) - real(r8), intent(in) :: rho_air ! local density of the air - real(r8), intent(in) :: rho_sub ! density of the particle substance + real(r8), intent(in) :: q !< mass mixing ratio + real(r8), intent(in) :: n !< number concentration (per volume) + real(r8), intent(in) :: rho_air !< local density of the air + real(r8), intent(in) :: rho_sub !< density of the particle substance avg_diameter = (pi * rho_sub * n/(q*rho_air))**(-oneo3) end function avg_diameter +!>\ingroup mg2mg3 +!> Finds a coefficient for process rates based on the relative variance +!! of cloud water. elemental function var_coef_r8(relvar, a) result(res) - ! Finds a coefficient for process rates based on the relative variance - ! of cloud water. real(r8), intent(in) :: relvar real(r8), intent(in) :: a real(r8) :: res @@ -801,9 +819,10 @@ elemental function var_coef_r8(relvar, a) result(res) end function var_coef_r8 +!>\ingroup mg2mg3 +!> Finds a coefficient for process rates based on the relative variance +!! of cloud water. elemental function var_coef_integer(relvar, a) result(res) - ! Finds a coefficient for process rates based on the relative variance - ! of cloud water. real(r8), intent(in) :: relvar integer, intent(in) :: a real(r8) :: res @@ -816,16 +835,17 @@ end function var_coef_integer !MICROPHYSICAL PROCESS CALCULATIONS !======================================================================== !======================================================================== -! Initial ice deposition and sublimation loop. -! Run before the main loop -! This subroutine written by Peter Caldwell - -subroutine ice_deposition_sublimation(t, qv, qi, ni, & +!>\ingroup micro_mg_utils_mod +!! Initial ice deposition and sublimation loop. +!! Run before the main loop +!! This subroutine written by Peter Caldwell +subroutine ice_deposition_sublimation(t, qv, qi, ni, & icldm, rho, dv,qvl, qvi, & berg, vap_dep, ice_sublim, mgncol) !INPUT VARS: !=============================================== +! logical, intent(in) :: lprnt integer, intent(in) :: mgncol real(r8), dimension(mgncol), intent(in) :: t real(r8), dimension(mgncol), intent(in) :: qv @@ -869,6 +889,9 @@ subroutine ice_deposition_sublimation(t, qv, qi, ni, & ! call size_dist_param_basic(mg_ice_props, qiic, niic, lami, n0i) call size_dist_param_ice(mg_ice_props, qiic, niic, lami, n0i) !Get depletion timescale=1/eps +! if(lprnt) write(0,*)' twopi=',twopi,' n0i=',n0i,' rho=',rho(1),& +! ' dv=',dv(1),' lami=',lami,' mg_ice_props=',mg_ice_props,& +! ' qiic=',qiic,'niic=',niic epsi = twopi*n0i*rho(i)*Dv(i)/(lami*lami) !Compute deposition/sublimation @@ -886,6 +909,9 @@ subroutine ice_deposition_sublimation(t, qv, qi, ni, & vap_dep(i) = zero end if +! if (lprnt) write(0,*)' t=',t(1),' tmelt=',tmelt,' epsi=',epsi,' ab=',ab,& +! ' ice_sublim=',ice_sublim(1),' vap_dep=',vap_dep(1),' qvl=',qvl(1),qvi(1) + !sublimation occurs @ any T. Not so for berg. if (t(i) < tmelt) then @@ -904,10 +930,10 @@ subroutine ice_deposition_sublimation(t, qv, qi, ni, & end subroutine ice_deposition_sublimation !======================================================================== -! autoconversion of cloud liquid water to rain -! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc -! minimum qc of 1 x 10^-8 prevents floating point error - +!>\ingroup micro_mg_utils_mod +!! autoconversion of cloud liquid water to rain +!! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc +!! minimum qc of 1 x 10^-8 prevents floating point error subroutine kk2000_liq_autoconversion(microp_uniform, qcic, & ncic, rho, relvar, prc, nprc, nprc1, mgncol) @@ -958,6 +984,8 @@ subroutine kk2000_liq_autoconversion(microp_uniform, qcic, & end subroutine kk2000_liq_autoconversion !======================================================================== +!>\ingroup micro_mg_utils_mod +!! This subroutine subroutine sb2001v2_liq_autoconversion(pgam,qc,nc,qr,rho,relvar,au,nprc,nprc1,mgncol) ! ! --------------------------------------------------------------------- @@ -1041,7 +1069,8 @@ subroutine sb2001v2_liq_autoconversion(pgam,qc,nc,qr,rho,relvar,au,nprc,nprc1,mg end subroutine sb2001v2_liq_autoconversion !======================================================================== -! Anning Cheng 10/5/2017 add Liu et al. autoconversion +!>\ingroup micro_mg_utils_mod +!! Anning Cheng 10/5/2017 add Liu et al. autoconversion subroutine liu_liq_autoconversion(pgam,qc,nc,qr,rho,relvar, & au,nprc,nprc1,mgncol) @@ -1098,7 +1127,7 @@ end subroutine liu_liq_autoconversion !======================================================================== !SB2001 Accretion V2 - +!>\ingroup micro_mg_utils_mod subroutine sb2001v2_accre_cld_water_rain(qc,nc,qr,rho,relvar,pra,npra,mgncol) ! ! --------------------------------------------------------------------- @@ -1152,7 +1181,9 @@ end subroutine sb2001v2_accre_cld_water_rain !======================================================================== ! Autoconversion of cloud ice to snow ! similar to Ferrier (1994) - +!>\ingroup micro_mg_utils_mod +!! Autoconversion of cloud ice to snow +!! similar to Ferrier (1994) subroutine ice_autoconversion(t, qiic, lami, n0i, dcs, ac_time, prci, nprci, mgncol) integer, intent(in) :: mgncol @@ -1199,6 +1230,8 @@ subroutine ice_autoconversion(t, qiic, lami, n0i, dcs, ac_time, prci, nprci, mgn end subroutine ice_autoconversion !=================================== ! Anning Cheng 10/5/2017 added GMAO ice autoconversion +!>\ingroup micro_mg_utils_mod +!! GMAO ice autoconversion subroutine gmao_ice_autoconversion(t, qiic, niic, lami, n0i, & dcs, ac_time, prci, nprci, mgncol) @@ -1234,7 +1267,8 @@ end subroutine gmao_ice_autoconversion !=================================== ! immersion freezing (Bigg, 1953) !=================================== - +!>\ingroup micro_mg_utils_mod +!! immersion freezing (Bigg, 1953) subroutine immersion_freezing(microp_uniform, t, pgam, lamc, & qcic, ncic, relvar, mnuccc, nnuccc, mgncol) @@ -1288,10 +1322,9 @@ subroutine immersion_freezing(microp_uniform, t, pgam, lamc, & end subroutine immersion_freezing -! contact freezing (-40\ingroup micro_mg_utils_mod +!! contact freezing (-40\ingroup micro_mg_utils_mod +!! snow self-aggregation from passarelli, 1978, used by reisner, 1998 !=================================================================== ! this is hard-wired for bs = 0.4 for now ! ignore self-collection of cloud ice - subroutine snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg, mgncol) integer, intent(in) :: mgncol @@ -1410,13 +1443,13 @@ subroutine snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg, mgncol) enddo end subroutine snow_self_aggregation -! accretion of cloud droplets onto snow/graupel +!>\ingroup micro_mg_utils_mod +!! accretion of cloud droplets onto snow/graupel !=================================================================== ! here use continuous collection equation with ! simple gravitational collection kernel ! ignore collisions between droplets/cloud ice ! since minimum size ice particle for accretion is 50 - 150 micron - subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, qsic, & pgam, lamc, lams, n0s, psacws, npsacws, mgncol) @@ -1483,10 +1516,10 @@ subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, qsic, & enddo end subroutine accrete_cloud_water_snow -! add secondary ice production due to accretion of droplets by snow +!>\ingroup micro_mg_utils_mod +!! add secondary ice production due to accretion of droplets by snow !=================================================================== ! (Hallet-Mossop process) (from Cotton et al., 1986) - subroutine secondary_ice_production(t, psacws, msacwi, nsacwi, mgncol) integer, intent(in) :: mgncol @@ -1516,10 +1549,10 @@ subroutine secondary_ice_production(t, psacws, msacwi, nsacwi, mgncol) enddo end subroutine secondary_ice_production -! accretion of rain water by snow +!>\ingroup micro_mg_utils_mod +!! accretion of rain water by snow !=================================================================== ! formula from ikawa and saito, 1991, used by reisner et al., 1998 - subroutine accrete_rain_snow(t, rho, umr, ums, unr, uns, qric, qsic, & lamr, n0r, lams, n0s, pracs, npracs, mgncol) @@ -1588,10 +1621,10 @@ subroutine accrete_rain_snow(t, rho, umr, ums, unr, uns, qric, qsic, & enddo end subroutine accrete_rain_snow -! heterogeneous freezing of rain drops +!>\ingroup micro_mg_utils_mod +!! heterogeneous freezing of rain drops !=================================================================== ! follows from Bigg (1953) - subroutine heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nnuccr, mgncol) integer, intent(in) :: mgncol @@ -1623,11 +1656,10 @@ subroutine heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nnuccr, mgnc enddo end subroutine heterogeneous_rain_freezing -! accretion of cloud liquid water by rain -!=================================================================== -! formula from Khrouditnov and Kogan (2000) +!>\ingroup micro_mg_utils_mod +!! accretion of cloud liquid water by rain +!! formula from Khrouditnov and Kogan (2000) ! gravitational collection kernel, droplet fall speed neglected - subroutine accrete_cloud_water_rain(microp_uniform, qric, qcic, & ncic, relvar, accre_enhan, pra, npra, mgncol) @@ -1675,10 +1707,9 @@ subroutine accrete_cloud_water_rain(microp_uniform, qric, qcic, & end do end subroutine accrete_cloud_water_rain -! Self-collection of rain drops -!=================================================================== -! from Beheng(1994) - +!>\ingroup micro_mg_utils_mod +!! Self-collection of rain drops +!! from Beheng(1994) subroutine self_collection_rain(rho, qric, nric, nragg, mgncol) integer, intent(in) :: mgncol @@ -1702,12 +1733,11 @@ subroutine self_collection_rain(rho, qric, nric, nragg, mgncol) enddo end subroutine self_collection_rain - -! Accretion of cloud ice by snow +!>\ingroup micro_mg_utils_mod +!! Accretion of cloud ice by snow !=================================================================== ! For this calculation, it is assumed that the Vs >> Vi ! and Ds >> Di for continuous collection - subroutine accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, & lams, n0s, prai, nprai, mgncol) @@ -1752,12 +1782,12 @@ subroutine accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, & enddo end subroutine accrete_cloud_ice_snow -! calculate evaporation/sublimation of rain and snow +!>\ingroup micro_mg_utils_mod +!! calculate evaporation/sublimation of rain and snow !=================================================================== ! note: evaporation/sublimation occurs only in cloud-free portion of grid cell ! in-cloud condensation/deposition of rain and snow is neglected ! except for transfer of cloud water to snow through bergeron process - subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, & lcldm, precip_frac, arn, asn, qcic, qiic, qric, qsic, lamr, n0r, lams, n0s, & pre, prds, am_evp_st, mgncol) @@ -1875,12 +1905,12 @@ subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, & end subroutine evaporate_sublimate_precip -! evaporation/sublimation of rain, snow and graupel +!>\ingroup micro_mg_utils_mod +!! evaporation/sublimation of rain, snow and graupel !=================================================================== ! note: evaporation/sublimation occurs only in cloud-free portion of grid cell ! in-cloud condensation/deposition of rain and snow is neglected ! except for transfer of cloud water to snow through bergeron process - subroutine evaporate_sublimate_precip_graupel(t, rho, dv, mu, sc, q, qvl, qvi, & lcldm, precip_frac, arn, asn, agn, bg, qcic, qiic, qric, qsic, qgic, lamr, n0r, lams, n0s, lamg, n0g, & pre, prds, prdg, am_evp_st, mgncol) @@ -2032,10 +2062,8 @@ subroutine evaporate_sublimate_precip_graupel(t, rho, dv, mu, sc, q, qvl, qvi, & end subroutine evaporate_sublimate_precip_graupel - -! bergeron process - evaporation of droplets and deposition onto snow -!=================================================================== - +!>\ingroup micro_mg_utils_mod +!! bergeron process - evaporation of droplets and deposition onto snow subroutine bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, & qcic, qsic, lams, n0s, bergs, mgncol) @@ -2084,9 +2112,8 @@ subroutine bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, & end subroutine bergeron_process_snow !======================================================================== -! Collection of snow by rain to form graupel -!======================================================================== - +!>\ingroup micro_mg_utils_mod +!! Collection of snow by rain to form graupel subroutine graupel_collecting_snow(qsic,qric,umr,ums,rho,lamr,n0r,lams,n0s, & psacr, mgncol) @@ -2146,9 +2173,8 @@ subroutine graupel_collecting_snow(qsic,qric,umr,ums,rho,lamr,n0r,lams,n0s, & end subroutine graupel_collecting_snow !======================================================================== -! Collection of cloud water by graupel -!======================================================================== - +!>\ingroup micro_mg_utils_mod +!! Collection of cloud water by graupel subroutine graupel_collecting_cld_water(qgic,qcic,ncic,rho,n0g,lamg,bg,agn, & psacwg, npsacwg, mgncol) @@ -2196,9 +2222,8 @@ subroutine graupel_collecting_cld_water(qgic,qcic,ncic,rho,n0g,lamg,bg,agn, & end subroutine graupel_collecting_cld_water !======================================================================== -! Conversion of rimed cloud water onto snow to graupel/hail -!======================================================================== - +!>\ingroup micro_mg_utils_mod +!! Conversion of rimed cloud water onto snow to graupel/hail subroutine graupel_riming_liquid_snow(psacws,qsic,qcic,nsic,rho,rhosn,rhog,asn,lams,n0s,dtime, & pgsacw,nscng,mgncol) @@ -2275,9 +2300,8 @@ subroutine graupel_riming_liquid_snow(psacws,qsic,qcic,nsic,rho,rhosn,rhog,asn,l end subroutine graupel_riming_liquid_snow !======================================================================== -!CHANGE IN Q,N COLLECTION RAIN BY GRAUPEL -!======================================================================== - +!>\ingroup micro_mg_utils_mod +!!CHANGE IN Q,N COLLECTION RAIN BY GRAUPEL subroutine graupel_collecting_rain(qric,qgic,umg,umr,ung,unr,rho,n0r,lamr,n0g,lamg,& pracg,npracg,mgncol) @@ -2376,10 +2400,10 @@ subroutine graupel_collecting_rain(qric,qgic,umg,umr,ung,unr,rho,n0r,lamr,n0g,la end subroutine graupel_collecting_rain !======================================================================== -! Rain riming snow to graupel +!>\ingroup micro_mg_utils_mod +!! Rain riming snow to graupel !======================================================================== ! Conversion of rimed rainwater onto snow converted to graupel - subroutine graupel_rain_riming_snow(pracs,npracs,psacr,qsic,qric,nric,nsic,n0s, & lams,n0r,lamr,dtime,pgracs,ngracs,mgncol) @@ -2470,6 +2494,8 @@ end subroutine graupel_rain_riming_snow !======================================================================== ! Rime Splintering !======================================================================== +!>\ingroup micro_mg_utils_mod +!! Rime splintering subroutine graupel_rime_splintering(t,qcic,qric,qgic,psacwg,pracg,& qmultg,nmultg,qmultrg,nmultrg,mgncol) @@ -2668,6 +2694,7 @@ end subroutine graupel_rime_splintering !UTILITIES !======================================================================== +!>\ingroup micro_mg_utils_mod pure function no_limiter() real(r8) :: no_limiter @@ -2675,6 +2702,7 @@ pure function no_limiter() end function no_limiter +!>\ingroup micro_mg_utils_mod pure function limiter_is_on(lim) real(r8), intent(in) :: lim logical :: limiter_is_on @@ -2683,6 +2711,7 @@ pure function limiter_is_on(lim) end function limiter_is_on +!>\ingroup micro_mg_utils_mod FUNCTION gamma_incomp(muice, x) real(r8) :: gamma_incomp diff --git a/gfsphysics/physics/moninshoc.f b/gfsphysics/physics/moninshoc.f index bce594d89..d68c001b5 100644 --- a/gfsphysics/physics/moninshoc.f +++ b/gfsphysics/physics/moninshoc.f @@ -83,6 +83,13 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, if (ix < im) stop ! ! if (lprnt) write(0,*)' in moninshoc tsea=',tsea(ipr) +! &, ' grav=',grav, rd, cp, hvap, fv,' ipr=',ipr +! &,' ntke=',ntke,' ntcw=',ntcw +! if (lprnt) write(0,*)' in moninshoc tin=',t1(ipr,:) +! if (lprnt) write(0,*)' in moninshoc qin=',q1(ipr,:,1) +! if (lprnt) write(0,*)' in moninshoc qwin=',q1(ipr,:,2) +! if (lprnt) write(0,*)' in moninshoc qiin=',q1(ipr,:,3) + dt2 = delt rdt = 1. / dt2 km1 = km - 1 @@ -125,8 +132,9 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo enddo ! if (lprnt) then -! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) -! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) +! write(0,*)' tx1=',tx1(ipr),' kinver=',kinver(ipr) +! write(0,*)' xkzo=',xkzo(ipr,:) +! write(0,*)' xkzmo=',xkzmo(ipr,:) ! endif ! ! diffusivity in the inversion layer is set to be xkzminv (m^2/s) @@ -332,6 +340,8 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, dkt(i,k) = max(min(tkh(i,kp1)+xkzo(i,k), dkmax), xkzo(i,k)) enddo enddo +! if (lprnt) write(0,*)' tkh=',tkh(ipr,:) +! if (lprnt) write(0,*)' dkt=',dkt(ipr,:) ! ! compute tridiagonal matrix elements for heat and moisture ! @@ -504,6 +514,8 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo endif ! +! if (lprnt) write(0,*)' in moninshoc tau=',tau(ipr,:)*86400 + return end subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) diff --git a/gfsphysics/physics/rascnvv2.f b/gfsphysics/physics/rascnvv2.f index ebc7c9fbb..4d49889de 100644 --- a/gfsphysics/physics/rascnvv2.f +++ b/gfsphysics/physics/rascnvv2.f @@ -315,7 +315,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & &, wfnc,tla,pl,qiid,qlid, c0, c0i, dlq_fac, sumq& &, rainp ! - Integer KCR, KFX, NCMX, NC, KTEM, I, L, lm1 & + Integer KCR, KFX, NCMX, NC, KTEM, I, ii, Lm1, l & &, ntrc, ia, ll, km1, kp1, ipt, lv, KBL, n & &, KRMIN, KRMAX, KFMAX, kblmx, irnd,ib & &, kblmn, ksfc @@ -339,6 +339,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! if (lprnt) write(0,*)' in RAS fscav=',fscav_,' ccwfac=', ! & ccwfac(ipr),' mp_phys=',mp_phys ! &, ' fscav=',fscav,' trac=',trac +! &, ' rannum=',rannum(1,:) ! km1 = k - 1 kp1 = k + 1 @@ -396,6 +397,9 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & enddo DO IPT=1,IM + lprint = lprnt .and. ipt == ipr + ia = ipr + ccwf = half if (ccwfac(ipt) >= zero) ccwf = ccwfac(ipt) @@ -403,6 +407,9 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & tem = one + dlq_fac c0 = c00(IPT) * tem c0i = c00i(IPT) * tem + +! if (lprint) write(0,*)' c0=',c0,' c0i=',c0i,' dlq_fac=',dlq_fac, & +! & ' ccwf=',ccwf ! ! ctei = .false. ! if (ctei_r(ipt) > ctei_rm) ctei = .true. @@ -437,7 +444,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & krmin = max(krmin,2) ! if (kdt == 1 .and. ipt == 1) write(0,*)' kblmn=',kblmn,kblmx -! if (lprnt .and. ipt == ipr) write(0,*)' krmin=',krmin,' krmax=', +! if (lprint) write(0,*)' krmin=',krmin,' krmax=', ! &krmax,' kfmax=',kfmax,' tem=',tem ! if (fix_ncld_hr) then @@ -460,8 +467,9 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & KTEM = MIN(K,KFMAX) KFX = KTEM - KCR -! if(lprnt)write(0,*)' enter RASCNV k=',k,' ktem=',ktem +! if(lprint)write(0,*)' enter RASCNV k=',k,' ktem=',ktem ! &, ' krmax=',krmax,' kfmax=',kfmax +! &, ' krmin=',krmin,' ncrnd=',ncrnd & ! &, ' kcr=',kcr, ' cdrag=',cdrag(ipr) IF (KFX > 0) THEN @@ -479,22 +487,24 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & NCMX = KFX + NCRND IF (NCRND > 0) THEN DO I=1,NCRND - IRND = (RANNUM(ipt,I)-0.0005)*(KCR-KRMIN+1) + II = mod(i-1,nrcm) + 1 + IRND = (RANNUM(ipt,II)-0.0005)*(KCR-KRMIN+1) IC(KFX+I) = IRND + KRMIN ENDDO ENDIF ! -! ia = 1 -! ! write(0,*)' in rascnv: k=',k,'lat=',lat,' lprnt=',lprnt -! if (lprnt) then +! if (lprint) then ! if (me == 0) then +! write(0,*)' ic=',ic(1:kfx+ncrnd) ! write(0,*)' tin',(tin(ia,l),l=k,1,-1) -! write(0,*)' qin',(qin(ia,l),l=k,1,-1) +! write(0,*)' qin',(qin(ia,l),l=k,1,-1),' kdt=',kdt,' me=',me +! write(0,*)' qwin',(ccin(ia,l,2),l=k,1,-1) +! write(0,*)' qiin',(ccin(ia,l,1),l=k,1,-1) ! endif ! ! - lprint = lprnt .and. ipt == ipr +! lprint = lprnt .and. ipt == ipr do l=1,k CLW(l) = zero @@ -1110,17 +1120,22 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ccin(ipt,l,2) = ccin(ipt,l,2) + clw(l) enddo endif + endif ! -! if (lprint) then -! write(0,*) ' tin',(tin(ia,l),l=k,1,-1) -! write(0,*) ' qin',(qin(ia,l),l=k,1,-1) -! endif ! - endif +! if (lprint) then +! write(0,*) ' endtin',(tin(ia,l),l=k,1,-1) +! write(0,*) ' endqin',(qin(ia,l),l=k,1,-1) +! write(0,*) ' endqwin',(ccin(ia,l,2),l=k,1,-1) +! write(0,*) ' endqiin',(ccin(ia,l,1),l=k,1,-1) +! endif +! ! ! Velocity scale from the downdraft! ! DDVEL(ipt) = DDVEL(ipt) * DDFAC * GRAV / (prs(KP1)-prs(K)) + +! if (lprint) write(0,*)' ddvel=',ddvel(ipt),' ddfac=',ddfac ! ENDDO ! End of the IPT Loop! @@ -1319,8 +1334,8 @@ SUBROUTINE CLOUD( & ! write(0,*) ' phil=',phil(KD:K) !! write(0,*) ' phih=',phih(kd:KP1),' kdt=',kdt ! write(0,*) ' phih=',phih(KD:KP1) -! write(0,*) ' toi=',toi -! write(0,*) ' qoi=',qoi +! write(0,*) ' toi=',toi(kd:k) +! write(0,*) ' qoi=',qoi(kd:k) ! endif ! CLDFRD = zero @@ -1702,8 +1717,10 @@ SUBROUTINE CLOUD( & ! ! if (ntk > 0 .and. do_aw) then if (ntk > 0) then - wcbase = min(2.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) -! wcbase = min(1.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) + if (rbl(ntk) > 0.0) then + wcbase = min(2.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) +! wcbase = min(1.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) + endif endif ! if (lprnt) write(0,*)' wcbase=',wcbase,' rbl=', @@ -2778,7 +2795,8 @@ SUBROUTINE CLOUD( & !! tem1 = sqrt(max(1.0, min(100.0,(4.0E10/max(garea,one))))) ! 20100902 tem1 = sqrt(max(one, min(100.0,(6.25E10/max(garea,one))))) ! 20110530 -! if (lprnt) write(0,*)' clfr0=',clf(tem),' tem=',tem,' tem1=',tem1 +! if (lprnt) write(0,*)' clfr0=',clf(tem),' tem=',tem,' tem1=', & +! & tem1 ! clfrac = max(ZERO, min(ONE, rknob*clf(tem)*tem1)) ! clfrac = max(ZERO, min(0.25, rknob*clf(tem)*tem1)) @@ -4410,8 +4428,9 @@ SUBROUTINE QSATCN(TT,P,Q,DQDT) real(kind=kind_phys) es, d, hlorv, W ! ! es = 10.0 * fpvs(tt) ! fpvs is in centibars! - es = 0.01 * fpvs(tt) ! fpvs is in Pascals! - D = one / max(p+epsm1*es,ONE_M10) + es = min(p, 0.01 * fpvs(tt)) ! fpvs is in Pascals! +! D = one / max(p+epsm1*es,ONE_M10) + D = one / (p+epsm1*es) ! q = MIN(eps*es*D, ONE) ! diff --git a/gfsphysics/physics/ugwp_driver_v0.f b/gfsphysics/physics/ugwp_driver_v0.f index cfc5505b1..dd3a3e2d0 100644 --- a/gfsphysics/physics/ugwp_driver_v0.f +++ b/gfsphysics/physics/ugwp_driver_v0.f @@ -46,7 +46,9 @@ subroutine cires_ugwp_driver_v0(me, master, &, rain real(kind=kind_phys), intent(in), dimension(im,levs) :: ugrs - &, vgrs, tgrs, qgrs, prsi, prsl, prslk, phii, phil, del + &, vgrs, tgrs, qgrs, prsl, prslk, phil, del + real(kind=kind_phys), intent(in), dimension(im,levs+1) :: prsi + &, phii ! real(kind=kind_phys), intent(in) :: oro_stat(im,nmtvr) real(kind=kind_phys), intent(in), dimension(im) :: hprime, oc diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 8dcb9ac88..74c0554a3 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1124,7 +1124,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%lakefrac(ix) = 0.0 else Sfcprop(nb)%landfrac(ix) = 0.0 - if (Sfcprop(nb)%oro_uf(ix) > 25.00) then + if (Sfcprop(nb)%oro_uf(ix) > 200.00) then Sfcprop(nb)%lakefrac(ix) = 1.0 ! lake else Sfcprop(nb)%lakefrac(ix) = 0.0 ! ocean From 3037555e50e95ecca2f9976bfb3e448ee9559ad6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 30 Dec 2019 17:36:00 +0000 Subject: [PATCH 11/91] updating mg driver, physics driver and typedef --- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 4 ++-- gfsphysics/GFS_layer/GFS_typedefs.F90 | 2 +- gfsphysics/physics/m_micro_driver.F90 | 8 ++++---- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index c0acf1868..454750825 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -3240,7 +3240,7 @@ subroutine GFS_physics_driver & do n=2,ntrac if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntlnc .and. n /= ntinc .and. & +! n /= ntlnc .and. n /= ntinc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then tracers = tracers + 1 do k=1,levs @@ -4341,7 +4341,7 @@ subroutine GFS_physics_driver & ! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntlnc .and. n /= ntinc .and. & +! n /= ntlnc .and. n /= ntinc .and. & n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then tracers = tracers + 1 do k=1,levs diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 143d91dfc..4b6de8660 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -5986,7 +5986,7 @@ subroutine interstitial_setup_tracers(Interstitial, Model) do n=2,Model%ntrac if ( n /= Model%ntcw .and. n /= Model%ntiw .and. n /= Model%ntclamt .and. & n /= Model%ntrw .and. n /= Model%ntsw .and. n /= Model%ntrnc .and. & - n /= Model%ntlnc .and. n /= Model%ntinc .and. & +! n /= Model%ntlnc .and. n /= Model%ntinc .and. & n /= Model%ntsnc .and. n /= Model%ntgl .and. n /= Model%ntgnc) then tracers = tracers + 1 if (Model%ntke == n ) then diff --git a/gfsphysics/physics/m_micro_driver.F90 b/gfsphysics/physics/m_micro_driver.F90 index 9d6e8be7a..26a04d96a 100644 --- a/gfsphysics/physics/m_micro_driver.F90 +++ b/gfsphysics/physics/m_micro_driver.F90 @@ -408,12 +408,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & QICN(I,K), CLCN(I,K), NCPL(I,K), & & NCPI(I,K), qc_min) if (rnw(i,k) <= qc_min(1)) then - ncpl(i,k) = 0.0 - elseif (ncpl(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpl(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0), nmin) + ncpr(i,k) = 0.0 + elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0), nmin) endif if (snw(i,k) <= qc_min(2)) then - ncpl(i,k) = 0.0 + ncps(i,k) = 0.0 elseif (ncps(i,k) <= nmin) then ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) endif From 86801388548ed58db7d3b186f596df8a9154c0b7 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 30 Dec 2019 17:47:17 +0000 Subject: [PATCH 12/91] updating gcm_shoc.f90 to turn on commented code in assumed pdf --- gfsphysics/physics/gcm_shoc.f90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 index 4693131ac..f5791a049 100644 --- a/gfsphysics/physics/gcm_shoc.f90 +++ b/gfsphysics/physics/gcm_shoc.f90 @@ -1496,9 +1496,9 @@ subroutine assumed_pdf() ! ' c1=',c1*100,' qs1=',qs1,' qw1_1=',qw1_1,' k=',k IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 -!! ELSEIF (s1 >= qcmin) THEN -!! C1 = one -!! qn1 = s1 + ELSEIF (s1 >= qcmin) THEN + C1 = one + qn1 = s1 ENDIF ! now compute non-precipitating cloud condensate @@ -1531,9 +1531,9 @@ subroutine assumed_pdf() wrk = s2 / (std_s2*sqrt2) C2 = max(zero, min(one, half*(one+erf(wrk)))) IF (C2 > zero) qn2 = s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk) -!! ELSEIF (s2 >= qcmin) THEN -!! C2 = one -!! qn2 = s2 + ELSEIF (s2 >= qcmin) THEN + C2 = one + qn2 = s2 ENDIF ENDIF From 4cd482f81c5bf783f6fc468a2abde0cfde7b629c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 8 Jan 2020 20:23:08 +0000 Subject: [PATCH 13/91] constraing imported ice fraction in atmos_model.F90 --- .gitmodules | 2 +- atmos_cubed_sphere | 2 +- atmos_model.F90 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index f8e75f557..cbde527f8 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,6 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere + url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 0e84f88b4..a56907a44 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 0e84f88b494b9e0a4097da50abe6b143330e8a2f +Subproject commit a56907a44461c7151e0ba266e160c8f1a1685882 diff --git a/atmos_model.F90 b/atmos_model.F90 index 6ec74d33f..3079d512c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1748,7 +1748,7 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Coupling%slimskin_cpl(ix) = IPD_Data(nb)%Sfcprop%slmsk(ix) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then if (datar8(i,j) >= IPD_control%min_seaice*IPD_Data(nb)%Sfcprop%oceanfrac(ix)) then - IPD_Data(nb)%Coupling%ficein_cpl(ix) = datar8(i,j) + IPD_Data(nb)%Coupling%ficein_cpl(ix) = max(zero, min(datar8(i,j),one)) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4. elseif (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) then From 3fe1183e53019f69d6ed5888b215b88a2f6649fb Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 10 Jan 2020 15:15:54 +0000 Subject: [PATCH 14/91] after merging with NOAA-EMC/fv3atm/develop --- atmos_cubed_sphere | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index a56907a44..8dd7628b3 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit a56907a44461c7151e0ba266e160c8f1a1685882 +Subproject commit 8dd7628b3e2d1db8a48d877b9fe561be66bbf472 From 826bba973bc11a607bed3c4719ae7abd4479fe9d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 11 Jan 2020 01:03:38 +0000 Subject: [PATCH 15/91] minor fix to atmos_model.F90 and IPD physics driver --- atmos_cubed_sphere | 2 +- atmos_model.F90 | 1 + gfsphysics/GFS_layer/GFS_physics_driver.F90 | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index a56907a44..0e84f88b4 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit a56907a44461c7151e0ba266e160c8f1a1685882 +Subproject commit 0e84f88b494b9e0a4097da50abe6b143330e8a2f diff --git a/atmos_model.F90 b/atmos_model.F90 index 3079d512c..3d221e61c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1941,6 +1941,7 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Coupling%dvsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%ulwsfcin_cpl(ix) = -99999.0 ! ,, + IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero endif endif enddo diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 0d970e789..92bbe64cb 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -2059,7 +2059,7 @@ subroutine GFS_physics_driver & Sfcprop%zorll(i) = zorl3(i,1) Sfcprop%zorlo(i) = zorl3(i,3) - if (flag_cice(i)) then ! this was already done for lake ice in sfc_sice + if (flag_cice(i) .and. wet(i)) then ! this was already done for lake ice in sfc_sice txi = Sfcprop%fice(i) txo = one - txi evap(i) = txi * evap3(i,2) + txo * evap3(i,3) From 2425771a902ed3b617fe6a70cbb4ee7fb7ec7aa5 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 13 Jan 2020 18:58:15 +0000 Subject: [PATCH 16/91] updating .gitmodules --- .gitmodules | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitmodules b/.gitmodules index cbde527f8..550c2fbf1 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,3 +8,4 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics + branch = SM_Jan102020 From e2fea18a22507f584ac14e541012910248cb4e92 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 14 Jan 2020 01:04:11 +0000 Subject: [PATCH 17/91] adding two couplrd suites --- ccpp/suites/suite_FV3_GFS_2017_coupled.xml | 2 +- ccpp/suites/suite_FV3_GFS_cpld_rasmgshoc.xml | 88 ++++++++++++++++++ .../suite_FV3_GFS_cpldnst_rasmgshoc.xml | 90 +++++++++++++++++++ 3 files changed, 179 insertions(+), 1 deletion(-) create mode 100644 ccpp/suites/suite_FV3_GFS_cpld_rasmgshoc.xml create mode 100644 ccpp/suites/suite_FV3_GFS_cpldnst_rasmgshoc.xml diff --git a/ccpp/suites/suite_FV3_GFS_2017_coupled.xml b/ccpp/suites/suite_FV3_GFS_2017_coupled.xml index 31a744176..4dc7e3851 100644 --- a/ccpp/suites/suite_FV3_GFS_2017_coupled.xml +++ b/ccpp/suites/suite_FV3_GFS_2017_coupled.xml @@ -57,7 +57,7 @@ GFS_GWD_generic_pre cires_ugwp cires_ugwp_post - GFS_GWD_generic_post + GFS_GWD_generic_post rayleigh_damp GFS_suite_stateout_update ozphys diff --git a/ccpp/suites/suite_FV3_GFS_cpld_rasmgshoc.xml b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshoc.xml new file mode 100644 index 000000000..ae5f11931 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshoc.xml @@ -0,0 +1,88 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + lsm_noah + sfc_ocean + sfc_cice + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + moninshoc + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + shoc + GFS_DCNV_generic_pre + GFS_suite_interstitial_5 + rascnv + GFS_DCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + m_micro_pre + m_micro + m_micro_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + diff --git a/ccpp/suites/suite_FV3_GFS_cpldnst_rasmgshoc.xml b/ccpp/suites/suite_FV3_GFS_cpldnst_rasmgshoc.xml new file mode 100644 index 000000000..bae10c10d --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_cpldnst_rasmgshoc.xml @@ -0,0 +1,90 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + sfc_nst_pre + sfc_nst + sfc_nst_post + lsm_noah + sfc_cice + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + moninshoc + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + shoc + GFS_DCNV_generic_pre + GFS_suite_interstitial_5 + rascnv + GFS_DCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + m_micro_pre + m_micro + m_micro_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + From 15e0c25c0d560217cb2c9e9e9e547c4b052ce099 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 16 Jan 2020 15:59:55 +0000 Subject: [PATCH 18/91] a bug fix in atmos_model.F90, added a logical frac_grid_off to enable reading fractional grid orography file and run as no fractional grid, and minor bug fix in physics driver related to the fractional grid - FV3GFS_io.F90 is modified to use lake fraction if it exists to distinguish lake from ocean --- atmos_cubed_sphere | 2 +- atmos_model.F90 | 3 ++- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 5 ++--- gfsphysics/GFS_layer/GFS_typedefs.F90 | 10 +++++++--- io/FV3GFS_io.F90 | 6 ++++-- 6 files changed, 17 insertions(+), 11 deletions(-) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 0e84f88b4..a56907a44 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 0e84f88b494b9e0a4097da50abe6b143330e8a2f +Subproject commit a56907a44461c7151e0ba266e160c8f1a1685882 diff --git a/atmos_model.F90 b/atmos_model.F90 index 3d221e61c..42d78d00b 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1941,7 +1941,8 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Coupling%dvsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%ulwsfcin_cpl(ix) = -99999.0 ! ,, - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero + if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) & + IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero ! 100% open water endif endif enddo diff --git a/ccpp/physics b/ccpp/physics index 647a9cf5e..372bd9d48 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 647a9cf5e91764fc2adb3bcbf4f3f33e54233f7a +Subproject commit 372bd9d48c3d5ef4c315ecab812fa96b00fed547 diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 6ffbbf13b..4be44ab22 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -1146,13 +1146,13 @@ subroutine GFS_physics_driver & fice(i) = zero endif endif -! if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) else fice(i) = zero endif ! ocean/lake area that is not frozen if (tem-fice(i) > epsln) then wet(i) = .true. ! there is some open water! + if (.not. Model%cplflx) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) ! if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), tgice) ! if (icy(i)) Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) endif @@ -1720,7 +1720,7 @@ subroutine GFS_physics_driver & tsurf3(i,3) = tsurf3(i,3) + tem endif enddo - if (Model%cplflx) then + if (Model%cplflx) then ! apply only at ocean points tem1 = half / omz1 do i=1,im if (wet(i) .and. Sfcprop%oceanfrac(i) > zero) then @@ -5462,7 +5462,6 @@ subroutine GFS_physics_driver & endif - ! --- ... coupling insertion if (Model%cplflx .or. Model%cplchm) then diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index dfa7d73ba..10b7cb783 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -927,6 +927,7 @@ module GFS_typedefs !< nstf_name(5) : zsea2 in mm !--- fractional grid logical :: frac_grid !< flag for fractional grid + logical :: frac_grid_off !< flag for using fractional grid real(kind=kind_phys) :: min_lakeice !< minimum lake ice value real(kind=kind_phys) :: min_seaice !< minimum sea ice value real(kind=kind_phys) :: rho_h2o !< density of fresh water @@ -3019,6 +3020,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< nstf_name(5) : zsea2 in mm !--- fractional grid logical :: frac_grid = .false. !< flag for fractional grid + logical :: frac_grid_off = .true. !< flag for using fractional grid real(kind=kind_phys) :: min_lakeice = 0.15d0 !< minimum lake ice value real(kind=kind_phys) :: min_seaice = 1.0d-11 !< minimum sea ice value real(kind=kind_phys) :: rho_h2o = rhowater !< fresh water density @@ -3159,7 +3161,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- near surface sea temperature model nst_anl, lsea, nstf_name, & frac_grid, min_lakeice, min_seaice, & - frac_grid, & + frac_grid_off, & !--- surface layer sfc_z0_type, & ! background vertical diffusion @@ -3587,10 +3589,11 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- fractional grid Model%frac_grid = frac_grid + Model%frac_grid_off = frac_grid_off #ifdef CCPP if (Model%frac_grid) then write(0,*) "ERROR: CCPP has not been tested with fractional landmask turned on" - stop +! stop end if #endif Model%min_lakeice = min_lakeice @@ -3969,7 +3972,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & if (Model%imp_physics /= Model%imp_physics_gfdl) stop 'iopt_snf == 4 must use GFDL MP' endif - print *,' nst_anl=',Model%nst_anl,' use_ufo=',Model%use_ufo,' frac_grid=',Model%frac_grid + print *,' nst_anl=',Model%nst_anl,' use_ufo=',Model%use_ufo,' frac_grid=',Model%frac_grid,& + ' frac_grid_off=',frac_grid_off print *,' min_lakeice=',Model%min_lakeice,' min_seaice=',Model%min_seaice if (Model%nstf_name(1) > 0 ) then print *,' NSSTM is active ' diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index a72b86d73..25d0694d0 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -625,6 +625,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if (nint(oro_var2(1,1,18)) == -9999._kind_phys) then ! lakefrac doesn't exist in the restart, need to create it if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - will computing lakefrac') Model%frac_grid = .false. + elseif (Model%frac_grid_off) then + Model%frac_grid = .false. else Model%frac_grid = .true. endif @@ -1140,8 +1142,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%landfrac(ix) = 1.0 ! land Sfcprop(nb)%lakefrac(ix) = 0.0 else - Sfcprop(nb)%landfrac(ix) = 0.0 - if (Sfcprop(nb)%oro_uf(ix) > 200.00) then + Sfcprop(nb)%landfrac(ix) = 0.0 ! water + if (Sfcprop(nb)%lakefrac(ix) > 0.0 .or. Sfcprop(nb)%oro_uf(ix) > 250.0) then Sfcprop(nb)%lakefrac(ix) = 1.0 ! lake else Sfcprop(nb)%lakefrac(ix) = 0.0 ! ocean From efe2053d901c77652543ad8557135e6817030bd8 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 28 Jan 2020 11:36:53 +0000 Subject: [PATCH 19/91] adding con_csol to GFS_typedefs.F90 and GFS_typedefs.meta for CCPP --- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_typedefs.F90 | 3 ++- gfsphysics/GFS_layer/GFS_typedefs.meta | 9 +++++++++ 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 372bd9d48..06aeee65e 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 372bd9d48c3d5ef4c315ecab812fa96b00fed547 +Subproject commit 06aeee65e2f084acba2340a1245f1722df26eaf4 diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 10b7cb783..c31c55d0d 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -8,7 +8,8 @@ module GFS_typedefs con_hvap, con_hfus, con_pi, con_rd, con_rv, & con_t0c, con_cvap, con_cliq, con_eps, con_epsq, & con_epsm1, con_ttp, rlapse, con_jcal, con_rhw0, & - con_sbc, con_tice, cimin, con_p0, rhowater + con_sbc, con_tice, cimin, con_p0, rhowater, & + con_csol use module_radsw_parameters, only: topfsw_type, sfcfsw_type, cmpfsw_type, NBDSW use module_radlw_parameters, only: topflw_type, sfcflw_type, NBDLW #else diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 3b3e2071d..21e2e4deb 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -8607,3 +8607,12 @@ dimensions = () type = real kind = kind_phys +[con_csol] + standard_name = specific_heat_of_ice_at_constant_pressure + long_name = specific heat of ice at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F From 6a4acdc9876853ebdc2943b6ebf124e899191e7d Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 30 Jan 2020 17:33:43 -0700 Subject: [PATCH 20/91] Update long names of hydrometeors to match the ccpp-physics change --- gfsphysics/GFS_layer/GFS_typedefs.meta | 40 +++++++++++++------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 21e2e4deb..48d26266b 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -148,42 +148,42 @@ kind = kind_phys [qgrs(:,:,index_for_liquid_cloud_condensate)] standard_name = cloud_condensed_water_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [qgrs(:,1,index_for_liquid_cloud_condensate)] standard_name = cloud_condensed_water_mixing_ratio_at_lowest_model_layer - long_name = moist (dry+vapor, no condensates) mixing ratio of cloud water at lowest model layer + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) at lowest model layer units = kg kg-1 dimensions = (horizontal_dimension) type = real kind = kind_phys [qgrs(:,:,index_for_ice_cloud_condensate)] standard_name = ice_water_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of ice water + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [qgrs(:,:,index_for_rain_water)] standard_name = rain_water_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of rain water + long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [qgrs(:,:,index_for_snow_water)] standard_name = snow_water_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of snow water + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [qgrs(:,:,index_for_graupel)] standard_name = graupel_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of graupel + long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real @@ -335,35 +335,35 @@ kind = kind_phys [gq0(:,:,index_for_liquid_cloud_condensate)] standard_name = cloud_condensed_water_mixing_ratio_updated_by_physics - long_name = moist (dry+vapor, no condensates) mixing ratio of cloud condensed water updated by physics + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) updated by physics units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [gq0(:,:,index_for_ice_cloud_condensate)] standard_name = ice_water_mixing_ratio_updated_by_physics - long_name = moist (dry+vapor, no condensates) mixing ratio of ice water updated by physics + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) updated by physics units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [gq0(:,:,index_for_rain_water)] standard_name = rain_water_mixing_ratio_updated_by_physics - long_name = moist (dry+vapor, no condensates) mixing ratio of rain water updated by physics + long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) updated by physics units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [gq0(:,:,index_for_snow_water)] standard_name = snow_water_mixing_ratio_updated_by_physics - long_name = moist (dry+vapor, no condensates) mixing ratio of snow water updated by physics + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) updated by physics units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [gq0(:,:,index_for_graupel)] standard_name = graupel_mixing_ratio_updated_by_physics - long_name = moist (dry+vapor, no condensates) mixing ratio of graupel updated by physics + long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) updated by physics units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real @@ -6217,14 +6217,14 @@ kind = kind_phys [clw(:,:,1)] standard_name = ice_water_mixing_ratio_convective_transport_tracer - long_name = moist (dry+vapor, no condensates) mixing ratio of ice water in the convectively transported tracer array + long_name = ratio of mass of ice water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [clw(:,:,2)] standard_name = cloud_condensed_water_mixing_ratio_convective_transport_tracer - long_name = moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) in the convectively transported tracer array + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) in the convectively transported tracer array units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real @@ -6448,21 +6448,21 @@ kind = kind_phys [dqdt(:,:,index_for_rain_water)] standard_name = tendency_of_rain_water_mixing_ratio_due_to_model_physics - long_name = moist (dry+vapor, no condensates) mixing ratio of rain water tendency due to model physics + long_name = ratio of mass of rain water tendency to mass of dry air plus vapor (without condensates) due to model physics units = kg kg-1 s-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [dqdt(:,:,index_for_snow_water)] standard_name = tendency_of_snow_water_mixing_ratio_due_to_model_physics - long_name = moist (dry+vapor, no condensates) mixing ratio of snow water tendency due to model physics + long_name = ratio of mass of snow water tendency to mass of dry air plus vapor (without condensates) due to model physics units = kg kg-1 s-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [dqdt(:,:,index_for_graupel)] standard_name = tendency_of_graupel_mixing_ratio_due_to_model_physics - long_name = moist (dry+vapor, no condensates) mixing ratio of graupel tendency due to model physics + long_name = ratio of mass of graupel tendency to mass of dry air plus vapor (without condensates) due to model physics units = kg kg-1 s-1 dimensions = (horizontal_dimension,vertical_dimension) type = real @@ -7490,7 +7490,7 @@ kind = kind_phys [qgl] standard_name = local_graupel_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of graupel local to physics + long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) local to physics units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real @@ -7518,14 +7518,14 @@ kind = kind_phys [qrn] standard_name = local_rain_water_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of rain water local to physics + long_name = ratio of mass of rain water to mass of dry air plus vapor (without condensates) local to physics units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys [qsnw] standard_name = local_snow_water_mixing_ratio - long_name = moist (dry+vapor, no condensates) mixing ratio of snow water local to physics + long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) local to physics units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real @@ -7657,7 +7657,7 @@ kind = kind_phys [save_q(:,:,index_for_liquid_cloud_condensate)] standard_name = cloud_condensed_water_mixing_ratio_save - long_name = moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) before entering a physics scheme + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme units = kg kg-1 dimensions = (horizontal_dimension,vertical_dimension) type = real From 9cf67326efe155149ecb9d6ff9e7bfde2026ef65 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 1 Feb 2020 01:04:21 +0000 Subject: [PATCH 21/91] reverting white space changes in .gitmodules --- .gitmodules | 8 ++++---- ccpp/physics | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index 550c2fbf1..75cde6477 100644 --- a/.gitmodules +++ b/.gitmodules @@ -3,9 +3,9 @@ url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere branch = dev/emc [submodule "ccpp/framework"] - path = ccpp/framework - url = https://github.com/NCAR/ccpp-framework + path = ccpp/framework + url = https://github.com/NCAR/ccpp-framework [submodule "ccpp/physics"] - path = ccpp/physics - url = https://github.com/SMoorthi-EMC/ccpp-physics + path = ccpp/physics + url = https://github.com/SMoorthi-EMC/ccpp-physics branch = SM_Jan102020 diff --git a/ccpp/physics b/ccpp/physics index 06aeee65e..b7e321b89 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 06aeee65e2f084acba2340a1245f1722df26eaf4 +Subproject commit b7e321b89dd6ddb724c6acd15108e87a6244c0e6 From 84c738e3c55ab3fb6844538f094d4f2761395574 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 4 Feb 2020 00:39:20 +0000 Subject: [PATCH 22/91] adding ignore_lake flag to GFS_typedefs.F90 andFV3GFS_io.F90 to preserve the option used in current s2s benchmarks --- gfsphysics/GFS_layer/GFS_typedefs.F90 | 7 +++++-- io/FV3GFS_io.F90 | 3 ++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index c31c55d0d..d6e8ac1d0 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -929,6 +929,7 @@ module GFS_typedefs !--- fractional grid logical :: frac_grid !< flag for fractional grid logical :: frac_grid_off !< flag for using fractional grid + logical :: ignore_lake !< flag for ignoring lakes real(kind=kind_phys) :: min_lakeice !< minimum lake ice value real(kind=kind_phys) :: min_seaice !< minimum sea ice value real(kind=kind_phys) :: rho_h2o !< density of fresh water @@ -3022,6 +3023,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- fractional grid logical :: frac_grid = .false. !< flag for fractional grid logical :: frac_grid_off = .true. !< flag for using fractional grid + logical :: ignore_lake = .true. !< flag for ignoring lakes real(kind=kind_phys) :: min_lakeice = 0.15d0 !< minimum lake ice value real(kind=kind_phys) :: min_seaice = 1.0d-11 !< minimum sea ice value real(kind=kind_phys) :: rho_h2o = rhowater !< fresh water density @@ -3162,7 +3164,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- near surface sea temperature model nst_anl, lsea, nstf_name, & frac_grid, min_lakeice, min_seaice, & - frac_grid_off, & + frac_grid_off, ignore_lake, & !--- surface layer sfc_z0_type, & ! background vertical diffusion @@ -3591,6 +3593,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- fractional grid Model%frac_grid = frac_grid Model%frac_grid_off = frac_grid_off + Model%ignore_lake = ignore_lake #ifdef CCPP if (Model%frac_grid) then write(0,*) "ERROR: CCPP has not been tested with fractional landmask turned on" @@ -3974,7 +3977,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif print *,' nst_anl=',Model%nst_anl,' use_ufo=',Model%use_ufo,' frac_grid=',Model%frac_grid,& - ' frac_grid_off=',frac_grid_off + ' frac_grid_off=',frac_grid_off,' ignore_lake=',ignore_lake print *,' min_lakeice=',Model%min_lakeice,' min_seaice=',Model%min_seaice if (Model%nstf_name(1) > 0 ) then print *,' NSSTM is active ' diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 25d0694d0..7119f7508 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1143,7 +1143,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%lakefrac(ix) = 0.0 else Sfcprop(nb)%landfrac(ix) = 0.0 ! water - if (Sfcprop(nb)%lakefrac(ix) > 0.0 .or. Sfcprop(nb)%oro_uf(ix) > 250.0) then + if (Sfcprop(nb)%lakefrac(ix) > 0.0 .or. & + (Sfcprop(nb)%oro_uf(ix) > 250.0 .and. .not. Model%ignore_lake) ) then Sfcprop(nb)%lakefrac(ix) = 1.0 ! lake else Sfcprop(nb)%lakefrac(ix) = 0.0 ! ocean From 4eee1847d9b47a9c39809d3011c527d5a8bbda9e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 10 Feb 2020 00:51:08 +0000 Subject: [PATCH 23/91] settng the momentum, sensible and latent heat fluxes over land exported to the mediator set to large values and over 100% sea ice set to values imported from icemodel. The mask identifying the ocean points to the mediator is correted based on ocean fraction. Updates also include name changes for the ice fields as changed by Denise Worthen. Also added an ignore_lake option to the namelist --- atmos_model.F90 | 46 +++++++++++---------- ccpp/physics | 2 +- cpl/module_cap_cpl.F90 | 8 +++- cpl/module_cplfields.F90 | 12 +++--- fv3_cap.F90 | 14 ++++--- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 23 +++++++---- module_fcst_grid_comp.F90 | 16 +++---- 7 files changed, 68 insertions(+), 53 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 42d78d00b..a34f3950f 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -223,7 +223,8 @@ module atmos_model_mod #endif real(kind=IPD_kind_phys), parameter :: zero = 0.0_IPD_kind_phys, & - one = 1.0_IPD_kind_phys + one = 1.0_IPD_kind_phys, & + puny = 1.0e-12_IPD_kind_phys contains @@ -1666,7 +1667,7 @@ subroutine assign_importdata(rc) ! endif -! get sea-state dependent surface roughness (if cplwav2atm=true) +! get sea-state dependent surface roughness (if cplwav2atm=true) !---------------------------- fldname = 'wave_z0_roughness_length' if (trim(impfield_name) == trim(fldname)) then @@ -1764,7 +1765,7 @@ subroutine assign_importdata(rc) ! get upward LW flux: for sea ice covered area !---------------------------------------------- - fldname = 'mean_up_lw_flx' + fldname = 'mean_up_lw_flx_ice' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) if (importFieldsValid(findex)) then @@ -1791,7 +1792,7 @@ subroutine assign_importdata(rc) ! get latent heat flux: for sea ice covered area !------------------------------------------------ - fldname = 'mean_laten_heat_flx' + fldname = 'mean_laten_heat_flx_atm_into_ice' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) if (importFieldsValid(findex)) then @@ -1811,7 +1812,7 @@ subroutine assign_importdata(rc) ! get sensible heat flux: for sea ice covered area !-------------------------------------------------- - fldname = 'mean_sensi_heat_flx' + fldname = 'mean_sensi_heat_flx_atm_into_ice' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) if (importFieldsValid(findex)) then @@ -1831,7 +1832,7 @@ subroutine assign_importdata(rc) ! get zonal compt of momentum flux: for sea ice covered area !------------------------------------------------------------ - fldname = 'mean_zonal_moment_flx' + fldname = 'stress_on_air_ice_zonal' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) if (importFieldsValid(findex)) then @@ -1851,7 +1852,7 @@ subroutine assign_importdata(rc) ! get meridional compt of momentum flux: for sea ice covered area !----------------------------------------------------------------- - fldname = 'mean_merid_moment_flx' + fldname = 'stress_on_air_ice_merid' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) if (importFieldsValid(findex)) then @@ -2542,7 +2543,8 @@ subroutine setup_exportdata (rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - exportData(i,j,idx) = IPD_Data(nb)%coupling%slmsk_cpl(ix) +! exportData(i,j,idx) = IPD_Data(nb)%coupling%slmsk_cpl(ix) + exportData(i,j,idx) = floor(one + puny - IPD_Data(nb)%SfcProp%oceanfrac(ix)) enddo enddo endif @@ -2561,7 +2563,7 @@ subroutine setup_exportdata (rc) exportData(i,j,idx) = DYCORE_Data(nb)%coupling%t_bot(ix) else exportData(i,j,idx) = zero - endif + endif enddo enddo endif @@ -2579,7 +2581,7 @@ subroutine setup_exportdata (rc) exportData(i,j,idx) = DYCORE_Data(nb)%coupling%tr_bot(ix,1) else exportData(i,j,idx) = zero - endif + endif enddo enddo endif @@ -2630,7 +2632,7 @@ subroutine setup_exportdata (rc) exportData(i,j,idx) = DYCORE_Data(nb)%coupling%p_bot(ix) else exportData(i,j,idx) = zero - endif + endif enddo enddo endif @@ -2646,8 +2648,8 @@ subroutine setup_exportdata (rc) if (associated(DYCORE_Data(nb)%coupling%z_bot)) then exportData(i,j,idx) = DYCORE_Data(nb)%coupling%z_bot(ix) else - exportData(i,j,idx) = zero - endif + exportData(i,j,idx) = zero + endif enddo enddo endif @@ -2666,14 +2668,14 @@ subroutine setup_exportdata (rc) enddo enddo endif - endif !cplflx + endif !cplflx !--- ! Fill the export Fields for ESMF/NUOPC style coupling call fillExportFields(exportData) !--- - if (IPD_Control%cplflx) then + if (IPD_Control%cplflx) then ! zero out accumulated fields !$omp parallel do default(shared) private(i,j,nb,ix) do j=jsc,jec @@ -2706,12 +2708,12 @@ subroutine setup_exportdata (rc) end subroutine setup_exportdata - subroutine addLsmask2grid(fcstgrid, rc) + subroutine addLsmask2grid(fcstGrid, rc) use ESMF ! implicit none - type(ESMF_Grid) :: fcstgrid + type(ESMF_Grid) :: fcstGrid integer, optional, intent(out) :: rc ! ! local vars @@ -2719,7 +2721,7 @@ subroutine addLsmask2grid(fcstgrid, rc) integer i, j, nb, ix ! integer CLbnd(2), CUbnd(2), CCount(2), TLbnd(2), TUbnd(2), TCount(2) type(ESMF_StaggerLoc) :: staggerloc - integer, allocatable :: lsmask(:,:) + integer, allocatable :: lsmask(:,:) integer(kind=ESMF_KIND_I4), pointer :: maskPtr(:,:) ! isc = IPD_control%isc @@ -2734,16 +2736,16 @@ subroutine addLsmask2grid(fcstgrid, rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) ! use land sea mask: land:1, ocean:0 - lsmask(i,j) = floor(IPD_Data(nb)%SfcProp%landfrac(ix)) + lsmask(i,j) = floor(one + puny - IPD_Data(nb)%SfcProp%oceanfrac(ix)) enddo enddo ! ! Get mask - call ESMF_GridAddItem(fcstgrid, itemflag=ESMF_GRIDITEM_MASK, & + call ESMF_GridAddItem(fcstGrid, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! call ESMF_GridGetItemBounds(fcstgrid, itemflag=ESMF_GRIDITEM_MASK, & +! call ESMF_GridGetItemBounds(fcstGrid, itemflag=ESMF_GRIDITEM_MASK, & ! staggerloc=ESMF_STAGGERLOC_CENTER, computationalLBound=ClBnd, & ! computationalUBound=CUbnd, computationalCount=Ccount, & ! totalLBound=TLbnd, totalUBound=TUbnd, totalCount=Tcount, rc=rc) @@ -2752,7 +2754,7 @@ subroutine addLsmask2grid(fcstgrid, rc) ! 'TlBnd=',TlBnd,'TUbnd=',TUbnd,'Tcount=',Tcount ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - call ESMF_GridGetItem(fcstgrid, itemflag=ESMF_GRIDITEM_MASK, & + call ESMF_GridGetItem(fcstGrid, itemflag=ESMF_GRIDITEM_MASK, & staggerloc=ESMF_STAGGERLOC_CENTER,farrayPtr=maskPtr, rc=rc) ! print *,'in set up grid, aft get maskptr, rc=',rc, 'size=',size(maskPtr,1),size(maskPtr,2), & ! 'bound(maskPtr)=', LBOUND(maskPtr,1),LBOUND(maskPtr,2),UBOUND(maskPtr,1),UBOUND(maskPtr,2) diff --git a/ccpp/physics b/ccpp/physics index b7e321b89..8a8de1740 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit b7e321b89dd6ddb724c6acd15108e87a6244c0e6 +Subproject commit 8a8de1740807e24a9e7198fad48414845347b205 diff --git a/cpl/module_cap_cpl.F90 b/cpl/module_cap_cpl.F90 index 3e858c0e0..a9c15ac9a 100644 --- a/cpl/module_cap_cpl.F90 +++ b/cpl/module_cap_cpl.F90 @@ -102,7 +102,7 @@ subroutine realizeConnectedCplFields(state, grid, numLevels, numSoilLayers, numTracers, & num_diag_sfc_emis_flux, num_diag_down_flux, & num_diag_type_down_flux, num_diag_burn_emis_flux, & - num_diag_cmass, fieldNames, fieldTypes, fieldList, rc) + num_diag_cmass, fieldNames, fieldTypes, fieldList, tag, rc) type(ESMF_State), intent(inout) :: state type(ESMF_Grid), intent(in) :: grid @@ -117,6 +117,7 @@ subroutine realizeConnectedCplFields(state, grid, character(len=*), dimension(:), intent(in) :: fieldNames character(len=*), dimension(:), intent(in) :: fieldTypes type(ESMF_Field), dimension(:), intent(out) :: fieldList + character(len=*), intent(in) :: tag !< Import or export. integer, intent(out) :: rc ! local variables @@ -196,10 +197,15 @@ subroutine realizeConnectedCplFields(state, grid, if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! -- save field fieldList(item) = field + call ESMF_LogWrite('realizeConnectedCplFields '//trim(tag)//' Field '//trim(fieldNames(item))// ' is connected ', & + ESMF_LOGMSG_INFO, line=__LINE__, file=__FILE__, rc=rc) else ! remove a not connected Field from State call ESMF_StateRemove(state, (/trim(fieldNames(item))/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_LogWrite('realizeConnectedCplFields '//trim(tag)//' Field '//trim(fieldNames(item))// ' is not connected ', & + ESMF_LOGMSG_INFO, line=__LINE__, file=__FILE__, rc=rc) end if end do diff --git a/cpl/module_cplfields.F90 b/cpl/module_cplfields.F90 index 82c04cd2e..cd87e3925 100644 --- a/cpl/module_cplfields.F90 +++ b/cpl/module_cplfields.F90 @@ -86,7 +86,7 @@ module module_cplfields "inst_merid_wind_height_lowest ", & "inst_pres_height_lowest ", & "inst_height_lowest ", & - "mean_fprec_rate " & + "mean_fprec_rate " & ! "northward_wind_neutral ", & ! "eastward_wind_neutral ", & ! "upward_wind_neutral ", & @@ -152,12 +152,12 @@ module module_cplfields ! "inst_ice_ir_dir_albedo ", & ! "inst_ice_vis_dif_albedo ", & ! "inst_ice_vis_dir_albedo ", & - "mean_up_lw_flx ", & - "mean_laten_heat_flx ", & - "mean_sensi_heat_flx ", & + "mean_up_lw_flx_ice ", & + "mean_laten_heat_flx_atm_into_ice ", & + "mean_sensi_heat_flx_atm_into_ice ", & ! "mean_evap_rate ", & - "mean_zonal_moment_flx ", & - "mean_merid_moment_flx ", & + "stress_on_air_ice_zonal ", & + "stress_on_air_ice_merid ", & "mean_ice_volume ", & "mean_snow_volume ", & "inst_tracer_up_surface_flx ", & diff --git a/fv3_cap.F90 b/fv3_cap.F90 index 9fc6ea718..1c54558d1 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -880,14 +880,16 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call realizeConnectedCplFields(exportState, fcstGrid, & numLevels, numSoilLayers, numTracers, num_diag_sfc_emis_flux, & num_diag_down_flux, num_diag_type_down_flux, num_diag_burn_emis_flux, & - num_diag_cmass, exportFieldsList, exportFieldTypes, exportFields, rc) + num_diag_cmass, exportFieldsList, exportFieldTypes, exportFields, & + 'FV3 Export',rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! -- realize connected fields in importState call realizeConnectedCplFields(importState, fcstGrid, & numLevels, numSoilLayers, numTracers, num_diag_sfc_emis_flux, & num_diag_down_flux, num_diag_type_down_flux, num_diag_burn_emis_flux, & - num_diag_cmass, importFieldsList, importFieldTypes, importFields, rc) + num_diag_cmass, importFieldsList, importFieldTypes, importFields, & + 'FV3 Import',rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return end if endif @@ -946,7 +948,7 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + !----------------------------------------------------------------------- !*** Use the internal Clock set by NUOPC layer for FV3 but update stopTime !----------------------------------------------------------------------- @@ -1001,7 +1003,7 @@ subroutine ModelAdvance(gcomp, rc) integrate: do while(.NOT.ESMF_ClockIsStopTime(clock_fv3, rc = RC)) ! !*** for forecast tasks - + timewri = mpi_wtime() call ESMF_LogWrite('Model Advance: before fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1236,7 +1238,7 @@ subroutine ModelAdvance_phase1(gcomp, rc) reconcileFlag = .true. !*** for forecast tasks - + call ESMF_LogWrite('Model Advance phase1: before fcstcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1258,7 +1260,7 @@ end subroutine ModelAdvance_phase1 subroutine ModelAdvance_phase2(gcomp, rc) type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc - + ! local variables type(ESMF_State) :: importState, exportState type(ESMF_Clock) :: clock diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 4be44ab22..cf8a1527c 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -2216,8 +2216,8 @@ subroutine GFS_physics_driver & Coupling%nlwsfc_cpl (i) = Coupling%nlwsfc_cpl(i) + Coupling%nlwsfci_cpl(i)*dtf Coupling%t2mi_cpl (i) = Sfcprop%t2m(i) Coupling%q2mi_cpl (i) = Sfcprop%q2m(i) -! Coupling%tsfci_cpl (i) = Sfcprop%tsfc(i) - Coupling%tsfci_cpl (i) = tsfc3(i,3) + Coupling%tsfci_cpl (i) = Sfcprop%tsfc(i) +! Coupling%tsfci_cpl (i) = tsfc3(i,3) Coupling%psurfi_cpl (i) = Statein%pgr(i) enddo @@ -2843,13 +2843,13 @@ subroutine GFS_physics_driver & if (Model%cplflx) then do i=1,im if (Sfcprop%oceanfrac(i) > zero) then ! Ocean only, NO LAKES -! if (Sfcprop%fice(i) == Sfcprop%oceanfrac(i)) then ! use results from CICE -! Coupling%dusfci_cpl(i) = dusfc_cice(i) -! Coupling%dvsfci_cpl(i) = dvsfc_cice(i) -! Coupling%dtsfci_cpl(i) = dtsfc_cice(i) -! Coupling%dqsfci_cpl(i) = dqsfc_cice(i) -! elseif (dry(i) .or. icy(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point - if (wet(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point + if (fice(i) == Sfcprop%oceanfrac(i)) then ! use results from CICE + Coupling%dusfci_cpl(i) = dusfc_cice(i) + Coupling%dvsfci_cpl(i) = dvsfc_cice(i) + Coupling%dtsfci_cpl(i) = dtsfc_cice(i) + Coupling%dqsfci_cpl(i) = dqsfc_cice(i) + + elseif (wet(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point if (icy(i) .or. dry(i)) then tem1 = max(Diag%q1(i), 1.e-8) rho = Statein%prsl(i,1) / (con_rd*Diag%t1(i)*(one+con_fvirt*tem1)) @@ -2878,6 +2878,11 @@ subroutine GFS_physics_driver & Coupling%dtsfc_cpl (i) = Coupling%dtsfc_cpl(i) + Coupling%dtsfci_cpl(i) * dtf Coupling%dqsfc_cpl (i) = Coupling%dqsfc_cpl(i) + Coupling%dqsfci_cpl(i) * dtf ! + else + Coupling%dusfc_cpl(i) = huge + Coupling%dvsfc_cpl(i) = huge + Coupling%dtsfc_cpl(i) = huge + Coupling%dqsfc_cpl(i) = huge endif ! Ocean only, NO LAKES enddo endif diff --git a/module_fcst_grid_comp.F90 b/module_fcst_grid_comp.F90 index fef9698ab..85cdbf98b 100644 --- a/module_fcst_grid_comp.F90 +++ b/module_fcst_grid_comp.F90 @@ -14,7 +14,7 @@ module module_fcst_grid_comp !*** Forecast gridded component. !----------------------------------------------------------------------- !*** -!*** HISTORY +!*** HISTORY !*** ! Apr 2017: J. Wang - initial code for forecast grid component ! @@ -61,7 +61,7 @@ module module_fcst_grid_comp use data_override_mod, only: data_override_init use fv_nggps_diags_mod, only: fv_dyn_bundle_setup use fv3gfs_io_mod, only: fv_phys_bundle_setup - + use fms_io_mod, only: field_exist, read_data use atmosphere_mod, only: atmosphere_control_data @@ -530,9 +530,9 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) if( cpl ) then call addLsmask2grid(fcstGrid, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! print *,'call addLsmask2grid after fcstgrid, rc=',rc +! print *,'call addLsmask2grid after fcstGrid, rc=',rc if( cplprint_flag ) then - call ESMF_GridWriteVTK(fcstgrid, staggerloc=ESMF_STAGGERLOC_CENTER, & + call ESMF_GridWriteVTK(fcstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, & filename='fv3cap_fv3Grid', rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return endif @@ -548,7 +548,7 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! Add dimension Attributes to Grid - call ESMF_AttributeAdd(fcstgrid, convention="NetCDF", purpose="FV3", & + call ESMF_AttributeAdd(fcstGrid, convention="NetCDF", purpose="FV3", & attrList=(/"ESMF:gridded_dim_labels"/), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -616,7 +616,7 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call fv_dyn_bundle_setup(atm_int_state%Atm%axes, & - fieldbundle, fcstgrid, quilting, rc=rc) + fieldbundle, fcstGrid, quilting, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! Add the field to the importState so parent can connect to it @@ -639,7 +639,7 @@ subroutine fcst_initialize(fcst_comp, importState, exportState, clock, rc) enddo ! call fv_phys_bundle_setup(atm_int_state%Atm%diag, atm_int_state%Atm%axes, & - fieldbundlephys, fcstgrid, quilting, nbdlphys) + fieldbundlephys, fcstGrid, quilting, nbdlphys) ! ! Add the field to the importState so parent can connect to it do j=1,nbdlphys @@ -857,7 +857,7 @@ subroutine fcst_finalize(fcst_comp, importState, exportState,clock,rc) ! integer :: unit integer,dimension(6) :: date - + real(8) mpi_wtime, tfs, tfe ! !----------------------------------------------------------------------- From 28a55c1969b0fefcf2defa5b8704995b14f07b67 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 10 Feb 2020 14:01:57 +0000 Subject: [PATCH 24/91] changing variable puny to epsln in atmos_model.F90 on Denise's recommendation --- atmos_model.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index a34f3950f..644326d2c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -224,7 +224,7 @@ module atmos_model_mod real(kind=IPD_kind_phys), parameter :: zero = 0.0_IPD_kind_phys, & one = 1.0_IPD_kind_phys, & - puny = 1.0e-12_IPD_kind_phys + epsln = 1.0e-12_IPD_kind_phys contains @@ -2544,7 +2544,7 @@ subroutine setup_exportdata (rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) ! exportData(i,j,idx) = IPD_Data(nb)%coupling%slmsk_cpl(ix) - exportData(i,j,idx) = floor(one + puny - IPD_Data(nb)%SfcProp%oceanfrac(ix)) + exportData(i,j,idx) = floor(one + epsln - IPD_Data(nb)%SfcProp%oceanfrac(ix)) enddo enddo endif @@ -2736,7 +2736,7 @@ subroutine addLsmask2grid(fcstGrid, rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) ! use land sea mask: land:1, ocean:0 - lsmask(i,j) = floor(one + puny - IPD_Data(nb)%SfcProp%oceanfrac(ix)) + lsmask(i,j) = floor(one + epsln - IPD_Data(nb)%SfcProp%oceanfrac(ix)) enddo enddo ! From 66e862219367b0aa72660f057269fe132892818d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 11 Feb 2020 19:11:30 +0000 Subject: [PATCH 25/91] added a new namelist parameter, min_lake_height, with default value of 250m, changeable by user to give more generality --- gfsphysics/GFS_layer/GFS_typedefs.F90 | 20 ++++++++++++-------- io/FV3GFS_io.F90 | 2 +- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index d6e8ac1d0..18f6f2c49 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -932,6 +932,7 @@ module GFS_typedefs logical :: ignore_lake !< flag for ignoring lakes real(kind=kind_phys) :: min_lakeice !< minimum lake ice value real(kind=kind_phys) :: min_seaice !< minimum sea ice value + real(kind=kind_phys) :: min_lake_height !< minimum lake height value real(kind=kind_phys) :: rho_h2o !< density of fresh water !--- surface layer z0 scheme @@ -3021,12 +3022,13 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< nstf_name(4) : zsea1 in mm !< nstf_name(5) : zsea2 in mm !--- fractional grid - logical :: frac_grid = .false. !< flag for fractional grid - logical :: frac_grid_off = .true. !< flag for using fractional grid - logical :: ignore_lake = .true. !< flag for ignoring lakes - real(kind=kind_phys) :: min_lakeice = 0.15d0 !< minimum lake ice value - real(kind=kind_phys) :: min_seaice = 1.0d-11 !< minimum sea ice value - real(kind=kind_phys) :: rho_h2o = rhowater !< fresh water density + logical :: frac_grid = .false. !< flag for fractional grid + logical :: frac_grid_off = .true. !< flag for using fractional grid + logical :: ignore_lake = .true. !< flag for ignoring lakes + real(kind=kind_phys) :: min_lakeice = 0.15d0 !< minimum lake ice value + real(kind=kind_phys) :: min_seaice = 1.0d-11 !< minimum sea ice value + real(kind=kind_phys) :: min_lake_height = 250.0 !< minimum lake height value + real(kind=kind_phys) :: rho_h2o = rhowater !< fresh water density !--- surface layer z0 scheme integer :: sfc_z0_type = 0 !< surface roughness options over ocean @@ -3163,7 +3165,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & clam_shal, c0s_shal, c1_shal, pgcon_shal, asolfac_shal, & !--- near surface sea temperature model nst_anl, lsea, nstf_name, & - frac_grid, min_lakeice, min_seaice, & + frac_grid, min_lakeice, min_seaice, min_lake_height, & frac_grid_off, ignore_lake, & !--- surface layer sfc_z0_type, & @@ -3602,6 +3604,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & #endif Model%min_lakeice = min_lakeice Model%min_seaice = min_seaice + Model%min_lake_height = min_lake_height Model%rho_h2o = rho_h2o !--- surface layer @@ -3978,7 +3981,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' nst_anl=',Model%nst_anl,' use_ufo=',Model%use_ufo,' frac_grid=',Model%frac_grid,& ' frac_grid_off=',frac_grid_off,' ignore_lake=',ignore_lake - print *,' min_lakeice=',Model%min_lakeice,' min_seaice=',Model%min_seaice + print *,' min_lakeice=',Model%min_lakeice,' min_seaice=',Model%min_seaice, & + 'min_lake_height=',Model%min_lake_height if (Model%nstf_name(1) > 0 ) then print *,' NSSTM is active ' print *,' nstf_name(1)=',Model%nstf_name(1) diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 140ac2169..25735d727 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1144,7 +1144,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) else Sfcprop(nb)%landfrac(ix) = 0.0 ! water if (Sfcprop(nb)%lakefrac(ix) > 0.0 .or. & - (Sfcprop(nb)%oro_uf(ix) > 250.0 .and. .not. Model%ignore_lake) ) then + (Sfcprop(nb)%oro_uf(ix) > Model%min_lake_height .and. .not. Model%ignore_lake) ) then Sfcprop(nb)%lakefrac(ix) = 1.0 ! lake else Sfcprop(nb)%lakefrac(ix) = 0.0 ! ocean From 7440f6938ac8cb30fd78f98c1e2356f5d089962a Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 19 Feb 2020 16:36:59 +0000 Subject: [PATCH 26/91] update gcycle --- ccpp/framework | 2 +- gfsphysics/physics/gcycle.F90 | 16 ++++++++++++---- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/ccpp/framework b/ccpp/framework index 7ab419eee..e77210986 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 7ab419eeebe133e706d9825d14c5bdc5d190e60d +Subproject commit e7721098639ee73c2a69ee0e8423e8905549e240 diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index 75618400e..bb17d54a6 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -57,7 +57,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) character(len=6) :: tile_num_ch real(kind=kind_phys), parameter :: pifac=180.0/pi - real(kind=kind_phys) :: sig1t + real(kind=kind_phys) :: sig1t, dt_warm integer :: npts, len, nb, ix, jx, ls, ios logical :: exists ! @@ -184,15 +184,23 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) close (Model%nlunit) #endif - len = 0 + len = 0 do nb = 1,nblks do ix = 1,size(Grid(nb)%xlat,1) len = len + 1 Sfcprop(nb)%slmsk (ix) = SLIFCS (len) if ( Model%nstf_name(1) > 0 ) then Sfcprop(nb)%tref(ix) = TSFFCS (len) + dt_warm = (Sfcprop(nb)%xt(ix) + Sfcprop(nb)%xt(ix) ) & + / Sfcprop(nb)%xz(ix) + Sfcprop(nb)%tsfco(ix) = Sfcprop(nb)%tref(ix) & + + dt_warm - Sfcprop(nb)%dt_cool(ix) else - Sfcprop(nb)%tsfc(ix) = TSFFCS (len) + Sfcprop(nb)%tsfc(ix) = TSFFCS (len) + Sfcprop(nb)%tsfco(ix) = TSFFCS (len) + endif + if (abs(slifcs(len) - 1.0) > 0.1) then + Sfcprop(nb)%tsfco(ix) = TSFFCS (len) endif Sfcprop(nb)%weasd (ix) = SNOFCS (len) Sfcprop(nb)%zorl (ix) = ZORFCS (len) @@ -233,6 +241,6 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) ! call mymaxmin(slifcs,len,len,1,'slifcs') ! ! if (Model%me .eq. 0) print*,'executed gcycle during hour=',fhour - + RETURN END From d587ec1307fef17b50593ff9c38c2db9f6bc7065 Mon Sep 17 00:00:00 2001 From: "Jun.Wang" Date: Mon, 24 Feb 2020 21:46:59 +0000 Subject: [PATCH 27/91] point atmos_cubed_sphere to NOAA-EMC repo and ccpp/physics to SMoorthi-EMC SM_Jan102020 branch --- .gitmodules | 2 +- atmos_cubed_sphere | 2 +- ccpp/physics | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 55d8e0bcc..04f33a38b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,6 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere + url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index a56907a44..db3acfbec 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit a56907a44461c7151e0ba266e160c8f1a1685882 +Subproject commit db3acfbec2ca00d1795b72b7ebf0b1e308506ced diff --git a/ccpp/physics b/ccpp/physics index a8384f09d..08aa96dc1 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit a8384f09d50a2ed398922c7c9a16489c0147c926 +Subproject commit 08aa96dc1b98713cb241975c0631302db428dcc8 From 302acd7e0bd57587ad20fb9af8334422a2de40a6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 26 Feb 2020 17:02:27 +0000 Subject: [PATCH 28/91] reverting definition of do_cnvgwd in GFS_typedefs.F90 --- gfsphysics/GFS_layer/GFS_typedefs.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index cf545a1d1..ea56d63a4 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -3545,7 +3545,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%rbcr = rbcr Model%do_gwd = maxval(Model%cdmbgwd) > 0.0 - Model%do_cnvgwd = Model%cnvgwd .and. (maxval(Model%cdmbgwd(3:4)) == 0.0 .and. .not. Model%do_ugwp) + Model%do_cnvgwd = Model%cnvgwd .and. maxval(Model%cdmbgwd(3:4)) == 0.0 #ifdef CCPP Model%do_mynnedmf = do_mynnedmf Model%do_mynnsfclay = do_mynnsfclay From 635053cdde07f75b2829867316c7874608fa9c6e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 26 Feb 2020 17:15:35 +0000 Subject: [PATCH 29/91] removed 3 lines from gcycle.F90, which I previously forgot to delete --- gfsphysics/physics/gcycle.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index bb17d54a6..c045d1efc 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -199,9 +199,6 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%tsfc(ix) = TSFFCS (len) Sfcprop(nb)%tsfco(ix) = TSFFCS (len) endif - if (abs(slifcs(len) - 1.0) > 0.1) then - Sfcprop(nb)%tsfco(ix) = TSFFCS (len) - endif Sfcprop(nb)%weasd (ix) = SNOFCS (len) Sfcprop(nb)%zorl (ix) = ZORFCS (len) Sfcprop(nb)%tg3 (ix) = TG3FCS (len) From bd8282e1d900b76c234e544e169894a1319217c8 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 26 Feb 2020 19:02:05 +0000 Subject: [PATCH 30/91] fixing a bug in gcycle update --- ccpp/physics | 2 +- gfsphysics/physics/gcycle.F90 | 12 +++++++----- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 08aa96dc1..21190a8d0 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 08aa96dc1b98713cb241975c0631302db428dcc8 +Subproject commit 21190a8d03d977b0569d39a34cb38d4cabee580e diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index c045d1efc..7c4861985 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -190,11 +190,13 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) len = len + 1 Sfcprop(nb)%slmsk (ix) = SLIFCS (len) if ( Model%nstf_name(1) > 0 ) then - Sfcprop(nb)%tref(ix) = TSFFCS (len) - dt_warm = (Sfcprop(nb)%xt(ix) + Sfcprop(nb)%xt(ix) ) & - / Sfcprop(nb)%xz(ix) - Sfcprop(nb)%tsfco(ix) = Sfcprop(nb)%tref(ix) & - + dt_warm - Sfcprop(nb)%dt_cool(ix) + Sfcprop(nb)%tref(ix) = TSFFCS (len) + if (Model%nstf_name(2) == 0) then + dt_warm = (Sfcprop(nb)%xt(ix) + Sfcprop(nb)%xt(ix) ) & + / Sfcprop(nb)%xz(ix) + Sfcprop(nb)%tsfco(ix) = Sfcprop(nb)%tref(ix) & + + dt_warm - Sfcprop(nb)%dt_cool(ix) + endif else Sfcprop(nb)%tsfc(ix) = TSFFCS (len) Sfcprop(nb)%tsfco(ix) = TSFFCS (len) From e28c52f214c390aeafe1a5a380df71b5613e35b7 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 27 Feb 2020 11:49:40 +0000 Subject: [PATCH 31/91] removing updating tsfco in gcycle when nsstr is on --- ccpp/physics | 2 +- gfsphysics/physics/gcycle.F90 | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 21190a8d0..593666151 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 21190a8d03d977b0569d39a34cb38d4cabee580e +Subproject commit 5936661510b5f8b28a52f0ecbc14599e3c46964c diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index 7c4861985..e3666c26a 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -191,12 +191,12 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%slmsk (ix) = SLIFCS (len) if ( Model%nstf_name(1) > 0 ) then Sfcprop(nb)%tref(ix) = TSFFCS (len) - if (Model%nstf_name(2) == 0) then - dt_warm = (Sfcprop(nb)%xt(ix) + Sfcprop(nb)%xt(ix) ) & - / Sfcprop(nb)%xz(ix) - Sfcprop(nb)%tsfco(ix) = Sfcprop(nb)%tref(ix) & - + dt_warm - Sfcprop(nb)%dt_cool(ix) - endif +! if (Model%nstf_name(2) == 0) then +! dt_warm = (Sfcprop(nb)%xt(ix) + Sfcprop(nb)%xt(ix) ) & +! / Sfcprop(nb)%xz(ix) +! Sfcprop(nb)%tsfco(ix) = Sfcprop(nb)%tref(ix) & +! + dt_warm - Sfcprop(nb)%dt_cool(ix) +! endif else Sfcprop(nb)%tsfc(ix) = TSFFCS (len) Sfcprop(nb)%tsfco(ix) = TSFFCS (len) From fdf4c9b709c751d51ac3b12abdfcab69ea74fab4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 5 Mar 2020 15:05:21 +0000 Subject: [PATCH 32/91] updated gcycle and sfcsub on the ipd side --- ccpp/physics | 2 +- gfsphysics/physics/gcycle.F90 | 8 + gfsphysics/physics/sfcsub.F | 1831 +++++++++++++++++---------------- 3 files changed, 946 insertions(+), 895 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 593666151..f8eb82ca3 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5936661510b5f8b28a52f0ecbc14599e3c46964c +Subproject commit f8eb82ca3da1e4dfd8665064998ff02279107002 diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index e3666c26a..b5cb28732 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -55,6 +55,8 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) STCFC1 (Model%nx*Model%ny*Model%lsoil), & SLCFC1 (Model%nx*Model%ny*Model%lsoil) + logical :: lake(Model%nx*Model%ny) + character(len=6) :: tile_num_ch real(kind=kind_phys), parameter :: pifac=180.0/pi real(kind=kind_phys) :: sig1t, dt_warm @@ -144,6 +146,11 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) ELSE AISFCS(len) = 0. ENDIF + if (Sfcprop(nb)%lakefrac(ix) > 0.0) then + lake(len) = .true. + else + lake(len) = .false. + endif ! if (Model%me .eq. 0) ! & print *,' len=',len,' rla=',rla(len),' rlo=',rlo(len) @@ -178,6 +185,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) CVBFCS, CVTFCS, Model%me, Model%nlunit, & size(Model%input_nml_file), & Model%input_nml_file, & + lake, Model%min_lakeice, Model%min_seaice, & Model%ialb, Model%isot, Model%ivegsrc, & trim(tile_num_ch), i_index, j_index) #ifndef INTERNAL_FILE_NML diff --git a/gfsphysics/physics/sfcsub.F b/gfsphysics/physics/sfcsub.F index 4fbabab8f..f3291e892 100644 --- a/gfsphysics/physics/sfcsub.F +++ b/gfsphysics/physics/sfcsub.F @@ -28,103 +28,107 @@ module sfccyc_module integer :: soil_type_landice ! end module sfccyc_module - subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc - &, iy,im,id,ih,fh - &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl - &, sihfcs,sicfcs,sitfcs - &, swdfcs,slcfcs - &, vmnfcs,vmxfcs,slpfcs,absfcs - &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs - &, vegfcs,vetfcs,sotfcs,alffcs - &, cvfcs,cvbfcs,cvtfcs,me,nlunit - &, sz_nml,input_nml_file + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & + &, iy,im,id,ih,fh & + &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl & + &, sihfcs,sicfcs,sitfcs & + &, swdfcs,slcfcs & + &, vmnfcs,vmxfcs,slpfcs,absfcs & + &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & + &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & + &, vegfcs,vetfcs,sotfcs,alffcs & + &, cvfcs,cvbfcs,cvtfcs,me,nlunit & + &, sz_nml,input_nml_file & + &, lake, min_lakeice, min_seaice & &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) ! use machine , only : kind_io8,kind_io4 use sfccyc_module implicit none - character(len=*), intent(in) :: tile_num_ch - integer,intent(in) :: i_index(len), j_index(len) - logical use_ufo, nst_anl - real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, - & orolmx,orolmn,oroomx,oroomn,orosmx, - & orosmn,oroimx,oroimn,orojmx,orojmn, - & alblmx,alblmn,albomx,albomn,albsmx, - & albsmn,albimx,albimn,albjmx,albjmn, - & wetlmx,wetlmn,wetomx,wetomn,wetsmx, - & wetsmn,wetimx,wetimn,wetjmx,wetjmn, - & snolmx,snolmn,snoomx,snoomn,snosmx, - & snosmn,snoimx,snoimn,snojmx,snojmn, - & zorlmx,zorlmn,zoromx,zoromn,zorsmx, - & zorsmn,zorimx,zorimn,zorjmx, zorjmn, - & plrlmx,plrlmn,plromx,plromn,plrsmx, - & plrsmn,plrimx,plrimn,plrjmx,plrjmn, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, - & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, - & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, - & stclmx,stclmn,stcomx,stcomn,stcsmx, - & stcsmn,stcimx,stcimn,stcjmx,stcjmn, - & smclmx,smclmn,smcomx,smcomn,smcsmx, - & smcsmn,smcimx,smcimn,smcjmx,smcjmn, - & scvlmx,scvlmn,scvomx,scvomn,scvsmx, - & scvsmn,scvimx,scvimn,scvjmx,scvjmn, - & veglmx,veglmn,vegomx,vegomn,vegsmx, - & vegsmn,vegimx,vegimn,vegjmx,vegjmn, - & vetlmx,vetlmn,vetomx,vetomn,vetsmx, - & vetsmn,vetimx,vetimn,vetjmx,vetjmn, - & sotlmx,sotlmn,sotomx,sotomn,sotsmx, - & sotsmn,sotimx,sotimn,sotjmx,sotjmn, - & alslmx,alslmn,alsomx,alsomn,alssmx, - & alssmn,alsimx,alsimn,alsjmx,alsjmn, - & epstsf,epsalb,epssno,epswet,epszor, - & epsplr,epsoro,epssmc,epsscv,eptsfc, - & epstg3,epsais,epsacn,epsveg,epsvet, - & epssot,epsalf,qctsfs,qcsnos,qctsfi, - & aislim,snwmin,snwmax,cplrl,cplrs, - & cvegl,czors,csnol,csnos,czorl,csots, - & csotl,cvwgs,cvetl,cvets,calfs, - & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, - & calbl,calfl,calbs,ctsfs,grboro, - & grbmsk,ctsfl,deltf,caisl,caiss, - & fsalfl,fsalfs,flalfs,falbl,ftsfl, - & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, - & faiss,fsnol,bltmsk,falbs,cvegs,percrit, - & deltsfc,critp2,critp3,blnmsk,critp1, - & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, - & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, - & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, - & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 - &, fsihl,fsihs,fsicl,fsics, - & csihl,csihs,csicl,csics,epssih,epssic - &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, - & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, - & epsslp,epsabs - &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, - & sihsmn,sihimx,sihimn,sihjmx,sihjmn, - & siclmx,siclmn,sicomx,sicomn,sicsmx, - & sicsmn,sicimx,sicimn,sicjmx,sicjmn - &, glacir_hice - &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, - & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, - & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, - & slplmx,slplmn,slpomx,slpomn,slpsmx, - & slpsmn,slpimx,slpimn,slpjmx,slpjmn, - & abslmx,abslmn,absomx,absomn,abssmx, - & abssmn,absimx,absimn,absjmx,absjmn + character(len=*), intent(in) :: tile_num_ch + integer, intent(in) :: i_index(len), j_index(len) + logical, intent(in) :: use_ufo, nst_anl + logical, intent(in) :: lake(len) + real (kind=kind_io8), intent(in) :: min_lakeice, min_seaice + + real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, & + & orolmx,orolmn,oroomx,oroomn,orosmx, & + & orosmn,oroimx,oroimn,orojmx,orojmn, & + & alblmx,alblmn,albomx,albomn,albsmx, & + & albsmn,albimx,albimn,albjmx,albjmn, & + & wetlmx,wetlmn,wetomx,wetomn,wetsmx, & + & wetsmn,wetimx,wetimn,wetjmx,wetjmn, & + & snolmx,snolmn,snoomx,snoomn,snosmx, & + & snosmn,snoimx,snoimn,snojmx,snojmn, & + & zorlmx,zorlmn,zoromx,zoromn,zorsmx, & + & zorsmn,zorimx,zorimn,zorjmx,zorjmn, & + & plrlmx,plrlmn,plromx,plromn,plrsmx, & + & plrsmn,plrimx,plrimn,plrjmx,plrjmn, & + & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, & + & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, & + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, & + & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, & + & stclmx,stclmn,stcomx,stcomn,stcsmx, & + & stcsmn,stcimx,stcimn,stcjmx,stcjmn, & + & smclmx,smclmn,smcomx,smcomn,smcsmx, & + & smcsmn,smcimx,smcimn,smcjmx,smcjmn, & + & scvlmx,scvlmn,scvomx,scvomn,scvsmx, & + & scvsmn,scvimx,scvimn,scvjmx,scvjmn, & + & veglmx,veglmn,vegomx,vegomn,vegsmx, & + & vegsmn,vegimx,vegimn,vegjmx,vegjmn, & + & vetlmx,vetlmn,vetomx,vetomn,vetsmx, & + & vetsmn,vetimx,vetimn,vetjmx,vetjmn, & + & sotlmx,sotlmn,sotomx,sotomn,sotsmx, & + & sotsmn,sotimx,sotimn,sotjmx,sotjmn, & + & alslmx,alslmn,alsomx,alsomn,alssmx, & + & alssmn,alsimx,alsimn,alsjmx,alsjmn, & + & epstsf,epsalb,epssno,epswet,epszor, & + & epsplr,epsoro,epssmc,epsscv,eptsfc, & + & epstg3,epsais,epsacn,epsveg,epsvet, & + & epssot,epsalf,qctsfs,qcsnos,qctsfi, & + & aislim,snwmin,snwmax,cplrl,cplrs, & + & cvegl,czors,csnol,csnos,czorl,csots, & + & csotl,cvwgs,cvetl,cvets,calfs, & + & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, & + & calbl,calfl,calbs,ctsfs,grboro, & + & grbmsk,ctsfl,deltf,caisl,caiss, & + & fsalfl,fsalfs,flalfs,falbl,ftsfl, & + & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, & + & faiss,fsnol,bltmsk,falbs,cvegs,percrit, & + & deltsfc,critp2,critp3,blnmsk,critp1, & + & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, & + & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, & + & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, & + & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 & + &, fsihl,fsihs,fsicl,fsics, & + & csihl,csihs,csicl,csics,epssih,epssic & + &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, & + & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, & + & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, & + & epsslp,epsabs & + &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, & + & sihsmn,sihimx,sihimn,sihjmx,sihjmn, & + & siclmx,siclmn,sicomx,sicomn,sicsmx, & + & sicsmn,sicimx,sicimn,sicjmx,sicjmn & + &, glacir_hice & + &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, & + & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, & + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, & + & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, & + & slplmx,slplmn,slpomx,slpomn,slpsmx, & + & slpsmn,slpimx,slpimn,slpjmx,slpjmn, & + & abslmx,abslmn,absomx,absomn,abssmx, & + & abssmn,absimx,absimn,absjmx,absjmn & &, sihnew - integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, - & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, - & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, - & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, - & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, - & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb + integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, & + & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, & + & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, & + & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, & + & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, & + & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb & &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc - logical gausm, deads, qcmsk, znlst, monclm, monanl, + logical gausm, deads, qcmsk, znlst, monclm, monanl, & & monfcs, monmer, mondif, landice character(len=*), intent(in) :: input_nml_file(sz_nml) @@ -265,8 +269,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! & sihsmx=8.0,sihsmn=0.0,sihimx=8.0,sihimn=0.10, ! & sihjmx=8.0,sihjmn=0.10,glacir_hice=3.0) parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, - & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15, - & sicjmx=1.0,sicjmn=0.15) + & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicjmx=1.0) +! & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15, +! & sicjmx=1.0,sicjmn=0.15) parameter(wetlmx=0.15,wetlmn=0.00,wetomx=0.15,wetomn=0.15, & wetsmx=0.15,wetsmn=0.15,wetimx=0.15,wetimn=0.15, @@ -415,7 +420,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! mask orography and variance on gaussian grid ! - real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) + real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) & &, orogd(len) real (kind=kind_io8) rla(len), rlo(len) ! @@ -428,50 +433,50 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! climatology surface fields (last character 'c' or 'clm' indicate climatology) ! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, - & fnvegc,fnvetc,fnsotc - &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 - real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), - & zorclm(len), albclm(len,4), aisclm(len), - & tg3clm(len), acnclm(len), cnpclm(len), - & cvclm (len), cvbclm(len), cvtclm(len), - & scvclm(len), tsfcl2(len), vegclm(len), - & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), - & smcclm(len,lsoil), stcclm(len,lsoil) - &, sihclm(len), sicclm(len) + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc & + &, fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc & + &, fnvegc,fnvetc,fnsotc & + &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 + real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len) & + &, zorclm(len), albclm(len,4), aisclm(len) & + &, tg3clm(len), acnclm(len), cnpclm(len) & + &, cvclm (len), cvbclm(len), cvtclm(len) & + &, scvclm(len), tsfcl2(len), vegclm(len) & + &, vetclm(len), sotclm(len), alfclm(len,2), sliclm(len) & + &, smcclm(len,lsoil), stcclm(len,lsoil) & + &, sihclm(len), sicclm(len) & &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) ! ! analyzed surface fields (last character 'a' or 'anl' indicate analysis) ! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, - & fnvega,fnveta,fnsota - &, fnvmna,fnvmxa,fnslpa,fnabsa -! - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & tg3anl(len), acnanl(len), cnpanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & scvanl(len), tsfan2(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), - & smcanl(len,lsoil), stcanl(len,lsoil) - &, sihanl(len), sicanl(len) + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa & + &, fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna & + &, fnvega,fnveta,fnsota & + &, fnvmna,fnvmxa,fnslpa,fnabsa +! + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len) & + &, zoranl(len), albanl(len,4), aisanl(len) & + &, tg3anl(len), acnanl(len), cnpanl(len) & + &, cvanl (len), cvbanl(len), cvtanl(len) & + &, scvanl(len), tsfan2(len), veganl(len) & + &, vetanl(len), sotanl(len), alfanl(len,2), slianl(len) & + &, smcanl(len,lsoil), stcanl(len,lsoil) & + &, sihanl(len), sicanl(len) & &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) ! real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0. ! ! predicted surface fields (last characters 'fcs' indicates forecast) ! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & tg3fcs(len), acnfcs(len), cnpfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2), - & smcfcs(len,lsoil), stcfcs(len,lsoil) - &, sihfcs(len), sicfcs(len), sitfcs(len) - &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len) & + &, zorfcs(len), albfcs(len,4), aisfcs(len) & + &, tg3fcs(len), acnfcs(len), cnpfcs(len) & + &, cvfcs (len), cvbfcs(len), cvtfcs(len) & + &, slifcs(len), vegfcs(len) & + &, vetfcs(len), sotfcs(len), alffcs(len,2) & + &, smcfcs(len,lsoil), stcfcs(len,lsoil) & + &, sihfcs(len), sicfcs(len), sitfcs(len) & + &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) & &, swdfcs(len), slcfcs(len,lsoil) ! ! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched @@ -553,8 +558,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! lqcbgs=.true. quality controls input bges file before merging (should have been ! qced in the forecast program) ! - logical ldebug,lqcbgs - logical lprnt + logical :: ldebug,lqcbgs, lprnt ! ! debug only ! @@ -775,7 +779,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc abslmn = .01 abssmn = .01 endif - if(ifp.eq.0) then + if (ifp == 0) then ifp = 1 do k=1,lsoil fsmcl(k) = 99999. @@ -792,15 +796,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc #endif ! write(6,namsfc) ! - if (me .eq. 0) then - print *,'ftsfl,falbl,faisl,fsnol,fzorl=', - & ftsfl,falbl,faisl,fsnol,fzorl - print *,'fsmcl=',fsmcl(1:lsoil) - print *,'fstcl=',fstcl(1:lsoil) - print *,'ftsfs,falbs,faiss,fsnos,fzors=', - & ftsfs,falbs,faiss,fsnos,fzors - print *,'fsmcs=',fsmcs(1:lsoil) - print *,'fstcs=',fstcs(1:lsoil) + if (me == 0) then + print *,' ftsfl,falbl,faisl,fsnol,fzorl=', & + & ftsfl,falbl,faisl,fsnol,fzorl + print *,' fsmcl=',fsmcl(1:lsoil) + print *,' fstcl=',fstcl(1:lsoil) + print *,' ftsfs,falbs,faiss,fsnos,fzors=', & + & ftsfs,falbs,faiss,fsnos,fzors + print *,' fsmcs=',fsmcs(1:lsoil) + print *,' fstcs=',fstcs(1:lsoil) print *,' aislim=',aislim,' sihnew=',sihnew print *,' isot=', isot,' ivegsrc=',ivegsrc endif @@ -818,176 +822,176 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! deltf = deltsfc / 24.0 ! - ctsfl=0. !... tsfc over land - if(ftsfl.ge.99999.) ctsfl=1. - if((ftsfl.gt.0.).and.(ftsfl.lt.99999)) ctsfl=exp(-deltf/ftsfl) + ctsfl = 0. !... tsfc over land + if (ftsfl >= 99999.) ctsfl = 1. + if (ftsfl > 0. .and. ftsfl < 99999) ctsfl = exp(-deltf/ftsfl) ! ctsfs=0. !... tsfc over sea - if(ftsfs.ge.99999.) ctsfs=1. - if((ftsfs.gt.0.).and.(ftsfs.lt.99999)) ctsfs=exp(-deltf/ftsfs) + if (ftsfs >= 99999.) ctsfs=1. + if (ftsfs > 0. .and. ftsfs < 99999) ctsfs = exp(-deltf/ftsfs) ! do k=1,lsoil - csmcl(k)=0. !... soilm over land - if(fsmcl(k).ge.99999.) csmcl(k)=1. - if((fsmcl(k).gt.0.).and.(fsmcl(k).lt.99999)) - & csmcl(k)=exp(-deltf/fsmcl(k)) + csmcl(k) = 0. !... soilm over land + if (fsmcl(k) >= 99999.) csmcl(k) = 1. + if (fsmcl(k) > 0. .and. fsmcl(k) < 99999) + & csmcl(k) = exp(-deltf/fsmcl(k)) csmcs(k)=0. !... soilm over sea - if(fsmcs(k).ge.99999.) csmcs(k)=1. - if((fsmcs(k).gt.0.).and.(fsmcs(k).lt.99999)) - & csmcs(k)=exp(-deltf/fsmcs(k)) + if (fsmcs(k) >= 99999.) csmcs(k) = 1. + if (fsmcs(k) > 0. .and. fsmcs(k) < 99999) + & csmcs(k) = exp(-deltf/fsmcs(k)) enddo ! - calbl=0. !... albedo over land - if(falbl.ge.99999.) calbl=1. - if((falbl.gt.0.).and.(falbl.lt.99999)) calbl=exp(-deltf/falbl) + calbl = 0. !... albedo over land + if (falbl >= 99999.) calbl = 1. + if (falbl > 0. .and. falbl < 99999) calbl = exp(-deltf/falbl) ! calfl=0. !... fraction field for albedo over land - if(falfl.ge.99999.) calfl=1. - if((falfl.gt.0.).and.(falfl.lt.99999)) calfl=exp(-deltf/falfl) + if (falfl >= 99999.) calfl = 1. + if (falfl > 0. .and. falfl < 99999) calfl = exp(-deltf/falfl) ! calbs=0. !... albedo over sea - if(falbs.ge.99999.) calbs=1. - if((falbs.gt.0.).and.(falbs.lt.99999)) calbs=exp(-deltf/falbs) + if (falbs >= 99999.) calbs = 1. + if (falbs > 0. .and. falbs < 99999) calbs = exp(-deltf/falbs) ! - calfs=0. !... fraction field for albedo over sea - if(falfs.ge.99999.) calfs=1. - if((falfs.gt.0.).and.(falfs.lt.99999)) calfs=exp(-deltf/falfs) + calfs = 0. !... fraction field for albedo over sea + if (falfs >= 99999.) calfs = 1. + if (falfs > 0. .and. falfs < 99999) calfs = exp(-deltf/falfs) ! - caisl=0. !... sea ice over land - if(faisl.ge.99999.) caisl=1. - if((faisl.gt.0.).and.(faisl.lt.99999)) caisl=1. + caisl = 0. !... sea ice over land + if (faisl >= 99999.) caisl = 1. + if (faisl > 0. .and. faisl < 99999) caisl = 1. ! - caiss=0. !... sea ice over sea - if(faiss.ge.99999.) caiss=1. - if((faiss.gt.0.).and.(faiss.lt.99999)) caiss=1. + caiss = 0. !... sea ice over sea + if (faiss >= 99999.) caiss = 1. + if (faiss > 0. .and. faiss < 99999) caiss = 1. ! - csnol=0. !... snow over land - if(fsnol.ge.99999.) csnol=1. - if((fsnol.gt.0.).and.(fsnol.lt.99999)) csnol=exp(-deltf/fsnol) + csnol = 0. !... snow over land + if (fsnol >= 99999.) csnol = 1. + if (fsnol > 0. .and. fsnol < 99999) csnol = exp(-deltf/fsnol) ! using the same way to bending snow as narr when fsnol is the negative value ! the magnitude of fsnol is the thread to determine the lower and upper bound ! of final swe - if(fsnol.lt.0.)csnol=fsnol + if (fsnol < 0.) csnol = fsnol ! - csnos=0. !... snow over sea - if(fsnos.ge.99999.) csnos=1. - if((fsnos.gt.0.).and.(fsnos.lt.99999)) csnos=exp(-deltf/fsnos) + csnos = 0. !... snow over sea + if (fsnos >= 99999.) csnos = 1. + if (fsnos > 0 .and. fsnos < 99999) csnos = exp(-deltf/fsnos) ! - czorl=0. !... roughness length over land - if(fzorl.ge.99999.) czorl=1. - if((fzorl.gt.0.).and.(fzorl.lt.99999)) czorl=exp(-deltf/fzorl) + czorl = 0. !... roughness length over land + if (fzorl >= 99999.) czorl = 1. + if (fzorl > 0. .and. fzorl < 99999) czorl = exp(-deltf/fzorl) ! - czors=0. !... roughness length over sea - if(fzors.ge.99999.) czors=1. - if((fzors.gt.0.).and.(fzors.lt.99999)) czors=exp(-deltf/fzors) + czors = 0. !... roughness length over sea + if (fzors >= 99999.) czors = 1. + if (fzors > 0. .and. fzors < 99999) czors = exp(-deltf/fzors) ! -! cplrl=0. !... plant resistance over land -! if(fplrl.ge.99999.) cplrl=1. -! if((fplrl.gt.0.).and.(fplrl.lt.99999)) cplrl=exp(-deltf/fplrl) +! cplrl = 0. !... plant resistance over land +! if (fplrl >= 99999.) cplrl = 1. +! if (fplrl > 0. .and. fplrl < 99999) cplrl=exp(-deltf/fplrl) ! -! cplrs=0. !... plant resistance over sea -! if(fplrs.ge.99999.) cplrs=1. -! if((fplrs.gt.0.).and.(fplrs.lt.99999)) cplrs=exp(-deltf/fplrs) +! cplrs = 0. !... plant resistance over sea +! if (fplrs >= 99999.) cplrs = 1. +! if (fplrs > 0. .and. fplrs < 99999) cplrs=exp(-deltf/fplrs) ! do k=1,lsoil - cstcl(k)=0. !... soilt over land - if(fstcl(k).ge.99999.) cstcl(k)=1. - if((fstcl(k).gt.0.).and.(fstcl(k).lt.99999)) - & cstcl(k)=exp(-deltf/fstcl(k)) - cstcs(k)=0. !... soilt over sea - if(fstcs(k).ge.99999.) cstcs(k)=1. - if((fstcs(k).gt.0.).and.(fstcs(k).lt.99999)) - & cstcs(k)=exp(-deltf/fstcs(k)) + cstcl(k) = 0. !... soilt over land + if (fstcl(k) >= 99999.) cstcl(k) = 1. + if (fstcl(k) > 0. .and. fstcl(k) < 99999) & + & cstcl(k) = exp(-deltf/fstcl(k)) + cstcs(k) = 0. !... soilt over sea + if (fstcs(k) >= 99999.) cstcs(k) = 1. + if (fstcs(k) > 0. .and. fstcs(k) < 99999) & + & cstcs(k) = exp(-deltf/fstcs(k)) enddo ! - cvegl=0. !... vegetation fraction over land - if(fvegl.ge.99999.) cvegl=1. - if((fvegl.gt.0.).and.(fvegl.lt.99999)) cvegl=exp(-deltf/fvegl) + cvegl = 0. !... vegetation fraction over land + if (fvegl >= 99999.) cvegl = 1. + if (fvegl > 0. .and. fvegl < 99999) cvegl = exp(-deltf/fvegl) ! - cvegs=0. !... vegetation fraction over sea - if(fvegs.ge.99999.) cvegs=1. - if((fvegs.gt.0.).and.(fvegs.lt.99999)) cvegs=exp(-deltf/fvegs) + cvegs = 0. !... vegetation fraction over sea + if (fvegs >= 99999.) cvegs = 1. + if (fvegs > 0. .and. fvegs < 99999) cvegs = exp(-deltf/fvegs) ! - cvetl=0. !... vegetation type over land - if(fvetl.ge.99999.) cvetl=1. - if((fvetl.gt.0.).and.(fvetl.lt.99999)) cvetl=exp(-deltf/fvetl) + cvetl = 0. !... vegetation type over land + if (fvetl >= 99999.) cvetl = 1. + if (fvetl > 0. .and. fvetl < 99999) cvetl = exp(-deltf/fvetl) ! - cvets=0. !... vegetation type over sea - if(fvets.ge.99999.) cvets=1. - if((fvets.gt.0.).and.(fvets.lt.99999)) cvets=exp(-deltf/fvets) + cvets = 0. !... vegetation type over sea + if (fvets >= 99999.) cvets = 1. + if (fvets > 0. .and. fvets < 99999) cvets = exp(-deltf/fvets) ! - csotl=0. !... soil type over land - if(fsotl.ge.99999.) csotl=1. - if((fsotl.gt.0.).and.(fsotl.lt.99999)) csotl=exp(-deltf/fsotl) + csotl = 0. !... soil type over land + if (fsotl >= 99999.) csotl = 1. + if (fsotl > 0. .and. fsotl < 99999) csotl = exp(-deltf/fsotl) ! - csots=0. !... soil type over sea - if(fsots.ge.99999.) csots=1. - if((fsots.gt.0.).and.(fsots.lt.99999)) csots=exp(-deltf/fsots) + csots = 0. !... soil type over sea + if (fsots >= 99999.) csots = 1. + if (fsots > 0. .and. fsots < 99999) csots = exp(-deltf/fsots) !cwu [+16l]--------------------------------------------------------------- ! - csihl=0. !... sea ice thickness over land - if(fsihl.ge.99999.) csihl=1. - if((fsihl.gt.0.).and.(fsihl.lt.99999)) csihl=exp(-deltf/fsihl) + csihl = 0. !... sea ice thickness over land + if (fsihl >= 99999.) csihl = 1. + if (fsihl > 0. .and. fsihl < 99999) csihl = exp(-deltf/fsihl) ! - csihs=0. !... sea ice thickness over sea - if(fsihs.ge.99999.) csihs=1. - if((fsihs.gt.0.).and.(fsihs.lt.99999)) csihs=exp(-deltf/fsihs) + csihs = 0. !... sea ice thickness over sea + if (fsihs >= 99999.) csihs = 1. + if (fsihs > 0. .and. fsihs < 99999) csihs = exp(-deltf/fsihs) ! - csicl=0. !... sea ice concentration over land - if(fsicl.ge.99999.) csicl=1. - if((fsicl.gt.0.).and.(fsicl.lt.99999)) csicl=exp(-deltf/fsicl) + csicl = 0. !... sea ice concentration over land + if (fsicl >= 99999.) csicl = 1. + if (fsicl > 0. .and. fsicl < 99999) csicl = exp(-deltf/fsicl) ! - csics=0. !... sea ice concentration over sea - if(fsics.ge.99999.) csics=1. - if((fsics.gt.0.).and.(fsics.lt.99999)) csics=exp(-deltf/fsics) + csics = 0. !... sea ice concentration over sea + if (fsics >= 99999.) csics = 1. + if (fsics > 0. .and. fsics < 99999) csics = exp(-deltf/fsics) !clu [+32l]--------------------------------------------------------------- ! - cvmnl=0. !... min veg cover over land - if(fvmnl.ge.99999.) cvmnl=1. - if((fvmnl.gt.0.).and.(fvmnl.lt.99999)) cvmnl=exp(-deltf/fvmnl) + cvmnl = 0. !... min veg cover over land + if (fvmnl >= 99999.) cvmnl = 1. + if (fvmnl > 0. .and. fvmnl < 99999) cvmnl = exp(-deltf/fvmnl) ! - cvmns=0. !... min veg cover over sea - if(fvmns.ge.99999.) cvmns=1. - if((fvmns.gt.0.).and.(fvmns.lt.99999)) cvmns=exp(-deltf/fvmns) + cvmns = 0. !... min veg cover over sea + if (fvmns >= 99999.) cvmns = 1. + if (fvmns > 0. .and. fvmns < 99999) cvmns = exp(-deltf/fvmns) ! - cvmxl=0. !... max veg cover over land - if(fvmxl.ge.99999.) cvmxl=1. - if((fvmxl.gt.0.).and.(fvmxl.lt.99999)) cvmxl=exp(-deltf/fvmxl) + cvmxl = 0. !... max veg cover over land + if (fvmxl >= 99999.) cvmxl = 1. + if (fvmxl > 0. .and. fvmxl < 99999) cvmxl = exp(-deltf/fvmxl) ! - cvmxs=0. !... max veg cover over sea - if(fvmxs.ge.99999.) cvmxs=1. - if((fvmxs.gt.0.).and.(fvmxs.lt.99999)) cvmxs=exp(-deltf/fvmxs) + cvmxs = 0. !... max veg cover over sea + if (fvmxs >= 99999.) cvmxs = 1. + if (fvmxs > 0. .and. fvmxs < 99999) cvmxs = exp(-deltf/fvmxs) ! - cslpl=0. !... slope type over land - if(fslpl.ge.99999.) cslpl=1. - if((fslpl.gt.0.).and.(fslpl.lt.99999)) cslpl=exp(-deltf/fslpl) + cslpl = 0. !... slope type over land + if (fslpl >= 99999.) cslpl = 1. + if (fslpl > 0. .and. fslpl < 99999) cslpl = exp(-deltf/fslpl) ! - cslps=0. !... slope type over sea - if(fslps.ge.99999.) cslps=1. - if((fslps.gt.0.).and.(fslps.lt.99999)) cslps=exp(-deltf/fslps) + cslps = 0. !... slope type over sea + if (fslps >= 99999.) cslps = 1. + if (fslps > 0. .and. fslps < 99999) cslps = exp(-deltf/fslps) ! - cabsl=0. !... snow albedo over land - if(fabsl.ge.99999.) cabsl=1. - if((fabsl.gt.0.).and.(fabsl.lt.99999)) cabsl=exp(-deltf/fabsl) + cabsl = 0. !... snow albedo over land + if (fabsl >= 99999.) cabsl = 1. + if (fabsl > 0. .and. fabsl < 99999) cabsl = exp(-deltf/fabsl) ! - cabss=0. !... snow albedo over sea - if(fabss.ge.99999.) cabss=1. - if((fabss.gt.0.).and.(fabss.lt.99999)) cabss=exp(-deltf/fabss) + cabss = 0. !... snow albedo over sea + if (fabss >= 99999.) cabss = 1. + if (fabss > 0. .and. fabss < 99999) cabss = exp(-deltf/fabss) !clu ---------------------------------------------------------------------- ! -! read a high resolution mask field for use in grib interpolation +!> - Call hmskrd() to read a high resolution mask field for use in grib interpolation ! - call hmskrd(lugb,imsk,jmsk,fnmskh, + call hmskrd(lugb,imsk,jmsk,fnmskh, & & kpdmsk,slmskh,gausm,blnmsk,bltmsk,me) ! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo) ! - if (me .eq. 0) then + if (me == 0) then write(6,*) ' ' write(6,*) ' lugb=',lugb,' len=',len, ' lsoil=',lsoil - write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh - &, ' sig1t(1)=',sig1t(1) + write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh & + &, ' sig1t(1)=',sig1t(1) & &, ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk write(6,*) ' ' endif @@ -1095,32 +1099,35 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc !* ice concentration or ice mask (only ice mask used in the model now) ! ice concentration and ice mask (both are used in the model now) ! - if(fnaisc(1:8).ne.' ') then + if(fnaisc(1:8) /= ' ') then !cwu [+5l/-1l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*aisclm(i) sicclm(i) = aisclm(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicclm(i).ne.1.) then + if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicclm(i) /= 1.0) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo crit=aislim !* crit=0.5 - call rof01(aisclm,len,'ge',crit) - elseif(fnacnc(1:8).ne.' ') then +! call rof01(aisclm,len,'ge',crit) + call rof01_len(aisclm, len, 'ge', lake, min_lakeice, min_seaice) + + elseif(fnacnc(1:8) /= ' ') then !cwu [+4l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*acnclm(i) sicclm(i) = acnclm(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicclm(i).ne.1.) then + if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicclm(i).ne.1.) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo - call rof01(acnclm,len,'ge',aislim) +! call rof01(acnclm,len,'ge',aislim) + call rof01_len(acnclm, len, 'ge', lake, min_lakeice, min_seaice) do i=1,len aisclm(i) = acnclm(i) enddo @@ -1175,7 +1182,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! quality control ! do i=1,len - icefl2(i) = sicclm(i) .gt. 0.99999 + icefl2(i) = sicclm(i) > 0.99999 enddo kqcm=1 call qcmxmn('tsfc ',tsfclm,sliclm,snoclm,icefl2, @@ -1227,17 +1234,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - if(fnstcc(1:8).eq.' ') then + if(fnstcc(1:8) == ' ') then call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) endif call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, @@ -1249,15 +1256,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add stcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1276,10 +1283,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, & sihjmx,sihjmn,sihsmx,sihsmn,epssih, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) +! call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1, +! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, +! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, +! & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+16l] --------------------------------------------------------------- call qcmxmn('vmnc ',vmnclm,sliclm,snoclm,icefl1, & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, @@ -1302,7 +1309,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! monitoring prints ! if (monclm) then - if (me .eq. 0) then + if (me == 0) then print *,' ' print *,'monitor of time and space interpolated climatology' print *,' ' @@ -1352,7 +1359,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc endif ! ! - if (me .eq. 0) then + if (me == 0) then write(6,*) '==============' write(6,*) ' analysis' write(6,*) '==============' @@ -1451,42 +1458,48 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! ice concentration or ice mask (only ice mask used in the model now) ! - if(fnaisa(1:8).ne.' ') then + if(fnaisa(1:8) /= ' ') then !cwu [+5l/-1l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*aisanl(i) sicanl(i) = aisanl(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicanl(i).ne.1.) then + if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice endif enddo - crit=aislim +! crit=aislim !* crit=0.5 - call rof01(aisanl,len,'ge',crit) - elseif(fnacna(1:8).ne.' ') then +! call rof01(aisanl,len,'ge',crit) + call rof01_len(aisanl, len, 'ge', lake, min_lakeice, min_seaice) + elseif(fnacna(1:8) /= ' ') then !cwu [+17l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*acnanl(i) sicanl(i) = acnanl(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicanl(i).ne.1.) then + if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice endif enddo - crit=aislim +! crit=aislim do i=1,len - if((slianl(i).eq.0.).and.(sicanl(i).ge.crit)) then - slianl(i)=2. + if (lake(i)) then + crit = min_lakeice + else + crit = min_seaice + endif + if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then + slianl(i) = 2. ! print *,'cycle - new ice form: fice=',sicanl(i) - else if((slianl(i).ge.2.).and.(sicanl(i).lt.crit)) then - slianl(i)=0. + elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then + slianl(i) = 0. ! print *,'cycle - ice free: fice=',sicanl(i) - else if((slianl(i).eq.1.).and.(sicanl(i).ge.sicimn)) then + elseif (nint(slianl(i)) == 1 .and. sicanl(i) > crit) then ! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i)=0. + sicanl(i) = 0. endif enddo ! znnt=10. @@ -1497,11 +1510,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! & .and. aisfcs(i) .ge. 0.75) acnanl(i) = aislim ! enddo ! if(lprnt) print *,' acnanl=',acnanl(iprnt) - call rof01(acnanl,len,'ge',aislim) +! call rof01(acnanl,len,'ge',aislim) + call rof01_len(acnanl, len, 'ge', lake, min_lakeice, min_seaice) do i=1,len - aisanl(i)=acnanl(i) + aisanl(i) = acnanl(i) enddo endif + ! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' ! &,glacir(iprnt),' slmask=',slmask(iprnt) ! @@ -1532,10 +1547,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, & sihjmx,sihjmn,sihsmx,sihsmn,epssih, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) +! call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1, +! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, +! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, +! & rla,rlo,len,kqcm,percrit,lgchek,me) ! ! set albedo over ocean to albomx ! @@ -1544,13 +1559,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! quality control of snow and sea-ice ! process snow depth or snow cover ! - if(fnsnoa(1:8).ne.' ') then + if (fnsnoa(1:8) /= ' ') then call setzro(snoanl,epssno,len) call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) if (.not.landice) then call snodpth2(glacir,snosmx,snoanl, len, me) endif - kqcm=1 + kqcm = 1 call snosfc(snoanl,tsfanl,tsfsmx,len,me) call qcmxmn('snoa ',snoanl,slianl,snoanl,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, @@ -1562,7 +1577,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, & rla,rlo,len,kqcm,percrit,lgchek,me) else - crit=0.5 + crit = 0.5 call rof01(scvanl,len,'ge',crit) call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1, @@ -1580,7 +1595,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc endif ! do i=1,len - icefl2(i) = sicanl(i) .gt. 0.99999 + icefl2(i) = sicanl(i) > 0.99999 enddo call qcmxmn('tsfa ',tsfanl,slianl,snoanl,icefl2, & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, @@ -1592,7 +1607,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & albjmx,albjmn,albsmx,albsmn,epsalb, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) then + if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ' ) then call qcmxmn('weta ',wetanl,slianl,snoanl,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, & wetjmx,wetjmn,wetsmx,wetsmn,epswet, @@ -1615,7 +1630,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! get soil temp and moisture ! - if(fnsmca(1:8).eq.' ' .and. fnsmcc(1:8).eq.' ') then + if(fnsmca(1:8) == ' ' .and. fnsmcc(1:8) == ' ') then call getsmc(wetanl,len,lsoil,smcanl,me) endif call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, @@ -1627,17 +1642,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - if(fnstca(1:8).eq.' ') then + if(fnstca(1:8) == ' ') then call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) endif call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, @@ -1649,15 +1664,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1693,7 +1708,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! monitoring prints ! if (monanl) then - if (me .eq. 0) then + if (me == 0) then print *,' ' print *,'monitor of time and space interpolated analysis' print *,' ' @@ -1742,20 +1757,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! read in forecast fields if needed ! - if (me .eq. 0) then + if (me == 0) then write(6,*) '==============' write(6,*) ' fcst guess' write(6,*) '==============' endif ! - percrit=critp2 + percrit = critp2 ! if(deads) then ! ! fill in guess array with analysis if dead start. ! - percrit=critp3 - if (me .eq. 0) write(6,*) 'this run is dead start run' + percrit = critp3 + if (me == 0) write(6,*) 'this run is dead start run' call filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & tg3fcs,cvfcs ,cvbfcs,cvtfcs, & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, @@ -1773,13 +1788,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc !clu [+1l] add ()anl for vmn, vmx, slp, abs & vmnanl,vmxanl,slpanl,absanl, & len,lsoil) - if(sig1t(1).ne.0.) then + if (sig1t(1) /= 0.) then call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, & tsfimx) do i=1,len - icefl2(i) = sicfcs(i) .gt. 0.99999 + icefl2(i) = sicfcs(i) > 0.99999 enddo - kqcm=1 + kqcm = 1 call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, @@ -1794,7 +1809,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & rla,rlo,len,kqcm,percrit,lgchek,me) endif else - percrit=critp2 + percrit = critp2 ! ! make reverse angulation correction to tsf ! make reverse orography correction to tg3 @@ -1823,7 +1838,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! do j=1, lsoil do i=1, len - if(smcfcs(i,j) .ne. 0.) then + if(smcfcs(i,j) /= 0.) then swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) else swratio(i,j) = -999. @@ -1832,13 +1847,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc enddo !clu ----------------------------------------------------------------------- ! - if(lqcbgs .and. irtacn .eq. 0) then + if (lqcbgs .and. irtacn == 0) then call qcsli(slianl,slifcs,len,me) call albocn(albfcs,slmask,albomx,len) do i=1,len icefl2(i) = sicfcs(i) .gt. 0.99999 enddo - kqcm=1 + kqcm = 1 call qcmxmn('snof ',snofcs,slifcs,snofcs,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, & snojmx,snojmn,snosmx,snosmn,epssno, @@ -1853,7 +1868,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & albjmx,albjmn,albsmx,albsmn,epsalb, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) + if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ' ) & then call qcmxmn('wetf ',wetfcs,slifcs,snofcs,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, @@ -1879,10 +1894,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, & sihjmx,sihjmn,sihsmx,sihsmn,epssih, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) +! call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1, +! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, +! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, +! & rla,rlo,len,kqcm,percrit,lgchek,me) call qcmxmn('smc1f ',smcfcs(1,1),slifcs,snofcs,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, @@ -1892,15 +1907,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, @@ -1911,15 +1926,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add stcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1956,7 +1971,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc endif ! if (monfcs) then - if (me .eq. 0) then + if (me == 0) then print *,' ' print *,'monitor of guess' print *,' ' @@ -1971,11 +1986,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc call monitr('stcfcs1',stcfcs(1,1),slifcs,snofcs,len) call monitr('stcfcs2',stcfcs(1,2),slifcs,snofcs,len) !clu [+4l] add smcfcs(3:4) and stcfcs(3:4) - if(lsoil.gt.2) then - call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) - call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) - call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) - call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) + if (lsoil > 2) then + call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) + call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) + call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) + call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) endif call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) call monitr('zorfcs',zorfcs,slifcs,snofcs,len) @@ -2023,14 +2038,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! blend climatology and predicted fields ! - if(me .eq. 0) then + if(me == 0) then write(6,*) '==============' write(6,*) ' merging' write(6,*) '==============' endif ! if(lprnt) print *,' tsffcs=',tsffcs(iprnt) ! - percrit=critp3 + percrit = critp3 ! ! merge analysis and forecast. note tg3, ais are not merged ! @@ -2084,9 +2099,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc call snosfc(snoanl,tsfanl,tsfsmx,len,me) ! do i=1,len - icefl2(i) = sicanl(i) .gt. 0.99999 + icefl2(i) = sicanl(i) > 0.99999 enddo - kqcm=0 + kqcm = 0 call qcmxmn('snowm ',snoanl,slianl,snoanl,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, & snojmx,snojmn,snosmx,snosmn,epssno, @@ -2101,8 +2116,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & albjmx,albjmn,albsmx,albsmn,epsalb, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) - & then + if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ' ) then call qcmxmn('wetm ',wetanl,slianl,snoanl,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, & wetjmx,wetjmn,wetsmx,wetsmn,epswet, @@ -2127,17 +2141,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, @@ -2146,18 +2149,26 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcanl(3:4) + if (lsoil > 2) then + call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - kqcm=1 + kqcm = 1 call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -2175,10 +2186,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, & sihjmx,sihjmn,sihsmx,sihsmn,epssih, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) +! call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1, +! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, +! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, +! & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+16l] add vmn, vmx, slp, abs call qcmxmn('vmnm ',vmnanl,slianl,snoanl,icefl1, & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, @@ -2198,7 +2209,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & rla,rlo,len,kqcm,percrit,lgchek,me) ! - if(me .eq. 0) then + if(me == 0) then write(6,*) '==============' write(6,*) 'final results' write(6,*) '==============' @@ -2228,7 +2239,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! check the final merged product ! if (monmer) then - if(me .eq. 0) then + if(me == 0) then print *,' ' print *,'monitor of updated surface fields' print *,' (includes angulation correction)' @@ -2244,13 +2255,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) !clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) - call monitr('tg3anl',tg3anl,slianl,snoanl,len) - call monitr('zoranl',zoranl,slianl,snoanl,len) + if (lsoil > 2) then + call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) + call monitr('tg3anl',tg3anl,slianl,snoanl,len) + call monitr('zoranl',zoranl,slianl,snoanl,len) endif ! if (gaus) then call monitr('cvaanl',cvanl ,slianl,snoanl,len) @@ -2312,7 +2323,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! monitoring prints ! - if(me .eq. 0) then + if(me == 0) then print *,' ' print *,'monitor of difference' print *,' (includes angulation correction)' @@ -2330,11 +2341,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc call monitr('stcanl1',stcfcs(1,1),slianl,snoanl,len) call monitr('stcanl2',stcfcs(1,2),slianl,snoanl,len) !clu [+4l] add smcfcs(3:4) and stc(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) + if (lsoil > 2) then + call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) endif call monitr('tg3dif',tg3fcs,slianl,snoanl,len) call monitr('zordif',zorfcs,slianl,snoanl,len) @@ -2405,15 +2416,21 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc enddo !cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points - crit=aislim +! crit=aislim do i=1,len sihfcs(i) = sihanl(i) sitfcs(i) = tsffcs(i) - if (slifcs(i).ge.2.) then - if (sicfcs(i).gt.crit) then + if (lake(i)) then + crit = min_lakeice + else + crit = min_seaice + endif + if (slifcs(i) >= 2.) then + if (sicfcs(i) > crit) then + tem1 = 1.0 / sicfcs(i) tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice)/sicfcs(i) - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) / sicfcs(i) + & + (sicfcs(i)-sicanl(i))*tgice) * tem1 + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 else tsffcs(i) = tsfanl(i) ! tsffcs(i) = tgice @@ -2423,13 +2440,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc sicfcs(i) = sicanl(i) enddo do i=1,len - if (slifcs(i).lt.1.5) then + if (slifcs(i) < 1.5) then sihfcs(i) = 0. sicfcs(i) = 0. sitfcs(i) = tsffcs(i) - else if ((slifcs(i).ge.1.5).and.(sicfcs(i).lt.crit)) then - print *,'warning: check, slifcs and sicfcs', - & slifcs(i),sicfcs(i) + else + if (lake(i)) then + crit = min_lakeice + else + crit = min_seaice + endif + if (sicfcs(i) < crit) then + print *,'warning: check, slifcs and sicfcs', & + & slifcs(i),sicfcs(i) + endif endif enddo @@ -2438,29 +2462,29 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! do k=1, lsoil fixratio(k) = .false. - if (fsmcl(k).lt.99999.) fixratio(k) = .true. + if (fsmcl(k) < 99999.) fixratio(k) = .true. enddo - if(me .eq. 0) then - print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) + if(me == 0) then + print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) endif do k=1, lsoil if(fixratio(k)) then do i = 1, len - if(swratio(i,k) .eq. -999.) then + if(swratio(i,k) == -999.) then slcfcs(i,k) = smcfcs(i,k) else slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) endif - if (slifcs(i) .ne. 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. + if (slifcs(i) /= 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. enddo endif enddo ! set liquid soil moisture to a flag value of 1.0 if (landice) then do i = 1, len - if (slifcs(i) .eq. 1.0 .and. + if (slifcs(i) == 1.0 .and. & nint(vetfcs(i)) == veg_type_landice) then do k=1, lsoil slcfcs(i,k) = 1.0 @@ -2471,13 +2495,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! ensure the consistency between snwdph and sheleg ! - if(fsnol .lt. 99999.) then - if(me .eq. 0) then - print *,'dbgx -- scale snwdph from sheleg' - endif - do i = 1, len - if(slifcs(i).eq.1.) swdfcs(i) = 10.* snofcs(i) - enddo + if(fsnol < 99999.) then + if(me == 0) then + print *,'dbgx -- scale snwdph from sheleg' + endif + do i = 1, len + if(slifcs(i) == 1.) swdfcs(i) = 10.* snofcs(i) + enddo endif ! sea ice model only uses the liquid equivalent depth. @@ -2485,14 +2509,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! use the same 3:1 ratio used by ice model. do i = 1, len - if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i) + if (slifcs(i) /= 1) swdfcs(i) = 3.*snofcs(i) enddo do i = 1, len - if(slifcs(i).eq.1.) then - if(snofcs(i).ne.0. .and. swdfcs(i).eq.0.) then - print *,'dbgx --scale snwdph from sheleg', - + i, swdfcs(i), snofcs(i) + if(slifcs(i) == 1.) then + if(snofcs(i) /= 0. .and. swdfcs(i) == 0.) then + print *,'dbgx --scale snwdph from sheleg', & + & i, swdfcs(i), snofcs(i) swdfcs(i) = 10.* snofcs(i) endif endif @@ -2504,7 +2528,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! after adjustment to terrain. if (landice) then do i = 1, len - if (slifcs(i) .eq. 1.0 .and. + if (slifcs(i) == 1.0 .and. & & nint(vetfcs(i)) == veg_type_landice) then snofcs(i) = max(snofcs(i),100.0) ! in mm swdfcs(i) = max(swdfcs(i),1000.0) ! in mm @@ -2648,7 +2672,7 @@ subroutine dayoyr(iyr,imo,idy,ldy) enddo return end - subroutine hmskrd(lugb,imsk,jmsk,fnmskh, + subroutine hmskrd(lugb,imsk,jmsk,fnmskh, & & kpds5,slmskh,gausm,blnmsk,bltmsk,me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata, xdata, ydata @@ -2681,7 +2705,7 @@ subroutine hmskrd(lugb,imsk,jmsk,fnmskh, ! return end - subroutine fixrdg(lugb,idim,jdim,fngrib, + subroutine fixrdg(lugb,idim,jdim,fngrib, & & kpds5,gdata,gaus,blno,blto,me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata @@ -2796,8 +2820,7 @@ subroutine fixrdg(lugb,idim,jdim,fngrib, deallocate(lbms) return end - subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr - &, me) + subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) use machine , only : kind_io8,kind_io4 implicit none integer j,me,kgds11 @@ -3006,16 +3029,16 @@ subroutine subst(data,imax,jmax,dlon,dlat,ijordr) endif return end - subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, - & gauout,len,lmask,rslmsk,slmask + subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& + & gauout,len,lmask,rslmsk,slmask & &, outlat, outlon,me) use machine , only : kind_io8,kind_io4 implicit none - real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, - & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, - & wi1j2,wi2j1,rlat,rlon,aphi, + real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, & + & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, & + & wi1j2,wi2j1,rlat,rlon,aphi, & & rnume,alamd,denom - integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, + integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, & & ii,i1,i2,kmami,it integer nx,kxs,kxt integer, allocatable, save :: imxnx(:) @@ -3023,7 +3046,7 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, ! ! interpolation from lat/lon or gaussian grid to other lat/lon grid ! - real (kind=kind_io8) outlon(len),outlat(len),gauout(len), + real (kind=kind_io8) outlon(len),outlat(len),gauout(len), & & slmask(len) real (kind=kind_io8) regin (imxin,jmxin),rslmsk(imxin,jmxin) ! @@ -3575,54 +3598,46 @@ subroutine maxmin(f,imax,kmax) ! return end - subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, - & aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, - & vetanl,sotanl,alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, - & aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, - & vetclm,sotclm,alfclm, -!cwu [+1l] add ()clm for sih, sic - & sihclm,sicclm, -!clu [+1l] add ()clm for vmn, vmx, slp, abs - & vmnclm,vmxclm,slpclm,absclm, + subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & + & aisanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, & + & vetanl,sotanl,alfanl, & + & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, & + & aisclm, & + & tg3clm,cvclm ,cvbclm,cvtclm, & + & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, & + & vetclm,sotclm,alfclm, & + & sihclm,sicclm, & !cwu [+1l] add ()clm for sih, sic + & vmnclm,vmxclm,slpclm,absclm, & !clu [+1l] add ()clm for vmn, vmx, slp, abs & len,lsoil) use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil ! - real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), - & snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),scvanl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs + real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), & + & snoanl(len), & + & zoranl(len),albanl(len,4),aisanl(len), & + & tg3anl(len), & + & cvanl (len),cvbanl(len),cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len),scvanl(len),veganl(len), & + & vetanl(len),sotanl(len),alfanl(len,2) & + &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) - real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), - & snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) -!cwu [+1l] add ()clm for sih, sic - &, sihclm(len),sicclm(len) -!clu [+1l] add ()clm for vmn, vmx, slp, abs + real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), & + & snoclm(len), & + & zorclm(len),albclm(len,4),aisclm(len), & + & tg3clm(len), & + & cvclm (len),cvbclm(len),cvtclm(len), & + & cnpclm(len), & + & smcclm(len,lsoil),stcclm(len,lsoil), & + & sliclm(len),scvclm(len),vegclm(len), & + & vetclm(len),sotclm(len),alfclm(len,2) & + &, sihclm(len),sicclm(len) & &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) ! do i=1,len @@ -3672,43 +3687,34 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, ! return end - subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota, -!clu [+1l] add fn()a for vmn, vmx, slp, abs - & fnvmna,fnvmxa,fnslpa,fnabsa, - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, - & vetanl,sotanl,alfanl,tsfan0, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, -!cggg snow mods start & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, -!cggg snow mods end - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kprvet,kpdsot,kpdalf, -!clu [+1l] add kpd() for vmn, vmx, slp, abs - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvet,irtsot,irtalf -!clu [+1l] add irt() for vmn, vmx, slp, abs - &, irtvmn,irtvmx,irtslp,irtabs - &, imsk, jmsk, slmskh, outlat, outlon + subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & + & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,& + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & + & fnveta,fnsota, & + & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs + & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & + & vetanl,sotanl,alfanl,tsfan0, & + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs + & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais,& + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & + & kprvet,kpdsot,kpdalf, & + & kpdvmn,kpdvmx,kpdslp,kpdabs, & !clu [+1l] add kpd() for vmn, vmx, slp, abs + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & !cggg snow mods + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & + & irtvet,irtsot,irtalf & + &, irtvmn,irtvmx,irtslp,irtabs & !clu [+1l] add irt() for vmn, vmx, slp, abs + &, imsk, jmsk, slmskh, outlat, outlon & &, gaus, blno, blto, me, lanom) use machine , only : kind_io8,kind_io4 implicit none logical lanom - integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, - & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, -!cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, - & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy, -!cggg snow mods end - & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, - & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j -!clu [+1l] add kpd() and irt() for vmn, vmx, slp, abs + integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, & + & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, & + & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy,& + & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, & + & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j & &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs real (kind=kind_io8) blto,blno,fh ! @@ -3721,21 +3727,19 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, integer lugi, lskip, lgrib, ndata !cggg snow mods end ! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & & fnveta,fnsota -!clu [+1l] add fn()a for vmn, vmx, slp, abs &, fnvmna,fnvmxa,fnslpa,fnabsa - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & tg3anl(len), acnanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & slianl(len), scvanl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), - & smcanl(len,lsoil), stcanl(len,lsoil), - & tsfan0(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), & + & zoranl(len), albanl(len,4), aisanl(len), & + & tg3anl(len), acnanl(len), & + & cvanl (len), cvbanl(len), cvtanl(len), & + & slianl(len), scvanl(len), veganl(len), & + & vetanl(len), sotanl(len), alfanl(len,2), & + & smcanl(len,lsoil), stcanl(len,lsoil), & + & tsfan0(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! logical gaus @@ -3788,36 +3792,36 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, endif else do i=1,len - tsfan0(i)=-999.9 + tsfan0(i) = -999.9 enddo endif ! ! albedo ! - irtalb=0 + irtalb = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 4 call fixrda(lugb,fnalba,kpdalb(kk),slmask, & iy,im,id,ih,fh,albanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - irtalb=iret - if(iret.eq.1) then + irtalb = iret + if(iret == 1) then write(6,*) 'albedo analysis read error' call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then + elseif(iret == -1) then + if (me == 0) then print *,'old albedo analysis provided, indicating proper', & ' file name is given. no error suspected.' write(6,*) 'forecast guess will be used' endif else - if (me .eq. 0 .and. kk .eq. 4) + if (me == 0 .and. kk == 4) & print *,'albedo analysis provided.' endif enddo else - if (me .eq. 0) then + if (me == 0) then ! print *,'************************************************' print *,'no albedo analysis available. climatology used' endif @@ -3825,30 +3829,30 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, ! ! vegetation fraction for albedo ! - irtalf=0 + irtalf = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 2 call fixrda(lugb,fnalba,kpdalf(kk),slmask, & iy,im,id,ih,fh,alfanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - irtalf=iret - if(iret.eq.1) then + irtalf = iret + if(iret == 1) then write(6,*) 'albedo analysis read error' call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then + elseif(iret == -1) then + if (me == 0) then print *,'old albedo analysis provided, indicating proper', & ' file name is given. no error suspected.' write(6,*) 'forecast guess will be used' endif else - if (me .eq. 0 .and. kk .eq. 4) + if (me == 0 .and. kk == 4) & print *,'albedo analysis provided.' endif enddo else - if (me .eq. 0) then + if (me == 0) then ! print *,'************************************************' print *,'no vegfalbedo analysis available. climatology used' endif @@ -4336,53 +4340,45 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, ! return end - subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, - & tg3fcs,cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, - & vegfcs, vetfcs, sotfcs, alffcs, -!cwu [+1l] add ()fcs for sih, sic - & sihfcs,sicfcs, -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsfanl,wetanl,snoanl,zoranl,albanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,aisanl, - & veganl, vetanl, sotanl, alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, + subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & + & tg3fcs,cvfcs ,cvbfcs,cvtfcs, & + & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, & + & vegfcs, vetfcs, sotfcs, alffcs, & + & sihfcs,sicfcs, & !cwu [+1l] add ()fcs for sih, sic + & vmnfcs,vmxfcs,slpfcs,absfcs, & !clu [+1l] add ()fcs for vmn, vmx, slp, abs + & tsfanl,wetanl,snoanl,zoranl,albanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,aisanl, & + & veganl, vetanl, sotanl, alfanl, & + & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs & len,lsoil) ! use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil - real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), - & zorfcs(len),albfcs(len,4),aisfcs(len), - & tg3fcs(len), - & cvfcs (len),cvbfcs(len),cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len),vegfcs(len), - & vetfcs(len),sotfcs(len),alffcs(len,2) -!cwu [+1l] add ()fcs for sih, sic - &, sihfcs(len),sicfcs(len) -!clu [+1l] add ()fcs for vmn, vmx, slp, abs + real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), & + & zorfcs(len),albfcs(len,4),aisfcs(len), & + & tg3fcs(len), & + & cvfcs (len),cvbfcs(len),cvtfcs(len), & + & cnpfcs(len), & + & smcfcs(len,lsoil),stcfcs(len,lsoil), & + & slifcs(len),vegfcs(len), & + & vetfcs(len),sotfcs(len),alffcs(len,2) & + &, sihfcs(len),sicfcs(len) & &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs + real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), & + & zoranl(len),albanl(len,4),aisanl(len), & + & tg3anl(len), & + & cvanl (len),cvbanl(len),cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len),veganl(len), & + & vetanl(len),sotanl(len),alfanl(len,2) & + &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! - write(6,*) ' this is a dead start run, tsfc over land is', + write(6,*) ' this is a dead start run, tsfc over land is', & & ' set as lowest sigma level temperture if given.' write(6,*) ' if not, set to climatological tsf over land is used' ! @@ -4433,7 +4429,7 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil,k - real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), + real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), & & slianl(len) ! ! note that smfcs comes in with the original unit (cm?) (not grib file) @@ -4456,43 +4452,97 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) ! return end - subroutine rof01(aisfld,len,op,crit) + subroutine rof01(aisfld, len, op, crit) use machine , only : kind_io8,kind_io4 implicit none integer i,len real (kind=kind_io8) aisfld(len),crit character*2 op ! - if(op.eq.'ge') then + if(op == 'ge') then + do i=1,len + if(aisfld(i) >= crit) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'gt') then + do i=1,len + if(aisfld(i) > crit) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'le') then + do i=1,len + if(aisfld(i) <= crit) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'lt') then + do i=1,len + if(aisfld(i) < crit) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + else + write(6,*) ' illegal operator in rof01. op=',op + call abort + endif +! + return + end + subroutine rof01_len(aisfld, len, op, lake, critl, crits) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + logical :: lake(len) + real (kind=kind_io8) aisfld(len), critl, crits, crit(len) + character*2 op +! + do i=1,len + if (lake(i)) then + crit(i) = critl + else + crit(i) = crits + endif + enddo + if(op == 'ge') then do i=1,len - if(aisfld(i).ge.crit) then - aisfld(i)=1. + if(aisfld(i) >= crit(i)) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo - elseif(op.eq.'gt') then + elseif(op == 'gt') then do i=1,len - if(aisfld(i).gt.crit) then - aisfld(i)=1. + if(aisfld(i) > crit(i)) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo - elseif(op.eq.'le') then + elseif(op == 'le') then do i=1,len - if(aisfld(i).le.crit) then - aisfld(i)=1. + if(aisfld(i) <= crit(i)) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo - elseif(op.eq.'lt') then + elseif(op == 'lt') then do i=1,len - if(aisfld(i).lt.crit) then - aisfld(i)=1. + if(aisfld(i) < crit(i)) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo else @@ -4517,7 +4567,7 @@ subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) enddo return end - subroutine snodpth(scvanl,slianl,tsfanl,snoclm, + subroutine snodpth(scvanl,slianl,tsfanl,snoclm, & & glacir,snwmax,snwmin,landice,len,snoanl, me) use machine , only : kind_io8,kind_io4 implicit none @@ -4525,7 +4575,7 @@ subroutine snodpth(scvanl,slianl,tsfanl,snoclm, logical, intent(in) :: landice real (kind=kind_io8) sno,snwmax,snwmin ! - real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), + real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), & & snoclm(len), snoanl(len), glacir(len) ! if (me .eq. 0) write(6,*) 'snodpth' @@ -4571,80 +4621,80 @@ subroutine snodpth(scvanl,slianl,tsfanl,snoclm, enddo return end subroutine snodpth - subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, - & cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, - & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,veganl, - & vetanl,sotanl,alfanl, - & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, - & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, - & calfl,calfs, - & csihl,csihs,csicl,csics, - & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, + subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & + & sihfcs,sicfcs, & + & vmnfcs,vmxfcs,slpfcs,absfcs, & + & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & + & cvfcs ,cvbfcs,cvtfcs, & + & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, & + & vetfcs,sotfcs,alffcs, & + & sihanl,sicanl, & + & vmnanl,vmxanl,slpanl,absanl, & + & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl,& + & cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,veganl, & + & vetanl,sotanl,alfanl, & + & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, & + & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, & + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, & + & calfl,calfs, & + & csihl,csihs,csicl,csics, & + & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & + & irtvmn,irtvmx,irtslp,irtabs, & & irtvet,irtsot,irtalf, landice, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : veg_type_landice, soil_type_landice implicit none - integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, - & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, - & irtalb,irtsno,irttsf,irtwet,j + integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & + & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & + & irtalb,irtsno,irttsf,irtwet,j & &, irtvmn,irtvmx,irtslp,irtabs logical, intent(in) :: landice - real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, - & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, - & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, - & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, - & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, - & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, - & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, - & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, - & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, - & cvets,calfs,deltsfc, - & csihl,csihs,csicl,csics, - & rsihl,rsihs,rsicl,rsics, - & qsihl,qsihs,qsicl,qsics - &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps - &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs - &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns + real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, & + & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, & + & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, & + & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, & + & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, & + & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, & + & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, & + & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, & + & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, & + & cvets,calfs,deltsfc, & + & csihl,csihs,csicl,csics, & + & rsihl,rsihs,rsicl,rsics, & + & qsihl,qsihs,qsicl,qsics & + &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps & + &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs & + &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns & &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss ! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2) - &, sihfcs(len), sicfcs(len) + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & + & zorfcs(len), albfcs(len,4), aisfcs(len), & + & cvfcs (len), cvbfcs(len), cvtfcs(len), & + & cnpfcs(len), & + & smcfcs(len,lsoil),stcfcs(len,lsoil), & + & slifcs(len), vegfcs(len), & + & vetfcs(len), sotfcs(len), alffcs(len,2) & + &, sihfcs(len), sicfcs(len) & &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),tsfan2(len), - & wetanl(len),snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2) - &, sihanl(len),sicanl(len) + real (kind=kind_io8) tsfanl(len),tsfan2(len), & + & wetanl(len),snoanl(len), & + & zoranl(len), albanl(len,4), aisanl(len), & + & cvanl (len), cvbanl(len), cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len), veganl(len), & + & vetanl(len), sotanl(len), alfanl(len,2) & + &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! - real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), + real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), & & cstcl(lsoil), cstcs(lsoil) - real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), + real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), & & rstcl(lsoil), rstcs(lsoil) - real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), + real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), & & qstcl(lsoil), qstcs(lsoil) logical first integer num_threads @@ -5022,18 +5072,17 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, !$omp end parallel do return end subroutine merge - subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, -!cwu [+1l] add sihnew,sicnew,sihanl,sicanl - & sihnew,sicnew,sihanl,sicanl, - & albanl,snoanl,zoranl,smcanl,stcanl, - & albsea,snosea,zorsea,smcsea,smcice, - & tsfmin,tsfice,albice,zorice,tgice, + subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & + & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl + & albanl,snoanl,zoranl,smcanl,stcanl, & + & albsea,snosea,zorsea,smcsea,smcice, & + & tsfmin,tsfice,albice,zorice,tgice, & & rla,rlo,me) ! use machine , only : kind_io8,kind_io4 implicit none real (kind=kind_io8), parameter :: one=1.0 - real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, + real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, & & smcice,tsfmin,zorsea,smcsea !cwu [+1l] add sicnew,sihnew &, sicnew,sihnew @@ -5118,7 +5167,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, ! return end - subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, + subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, & & landice,me) use machine , only : kind_io8,kind_io4 implicit none @@ -5164,20 +5213,20 @@ subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, endif return end subroutine qcsnow - subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, + subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, & & rla,rlo,len,me) use machine , only : kind_io8,kind_io4 implicit none integer kount1,kount,i,me,len real (kind=kind_io8) per,aicsea,aicice,sllnd ! - real (kind=kind_io8) ais(len), glacir(len), + real (kind=kind_io8) ais(len), glacir(len), & & amxice(len), slmask(len) real (kind=kind_io8) rla(len), rlo(len) ! ! check sea-ice cover mask against land-sea mask ! - if (me .eq. 0) write(6,*) 'qc of sea ice' + if (me == 0) write(6,*) 'qc of sea ice' kount = 0 kount1 = 0 do i=1,len @@ -5275,9 +5324,8 @@ subroutine setlsi(slmask,aisfld,len,aicice,slifld) ! do i=1,len slifld(i) = slmask(i) -! if(aisfld(i).eq.aicice) slifld(i) = 2.0 - if(aisfld(i).eq.aicice .and. slmask(i) .eq. 0.0) - & slifld(i) = 2.0 + if(aisfld(i) == aicice .and. slmask(i) == 0.0) & + & slifld(i) = 2.0 enddo return end @@ -5292,66 +5340,63 @@ subroutine scale(fld,len,scl) enddo return end - subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, - & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, - & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, + subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & + & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, & + & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, & & rla,rlo,len,mode,percrit,lgchek,me) ! use machine , only : kind_io8,kind_io4 implicit none - real (kind=kind_io8) permax,per,fldimx,fldimn,fldjmx,fldomn, - & fldlmx,fldlmn,fldomx,fldjmn,percrit, - & fldsmx,fldsmn,epsfld - integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj, - & ij,nprt,kmaxs,kmins,i,me,len,mode - parameter(mmprt=2) + integer, intent(in) :: len, mode, me + real (kind=kind_io8), intent(in) :: fldimx,fldimn,fldjmx,fldomn, & + & fldlmx,fldlmn,fldomx,fldjmn, & + & fldsmx,fldsmn,epsfld,percrit & + integer, parameter :: mmprt=2 ! character*8 ttl logical iceflg(len) - real (kind=kind_io8) fld(len),slimsk(len),sno(len), - & rla(len), rlo(len) - integer iwk(len) + real (kind=kind_io8), dimension(len) :: fld, slimsk, sno, rla, rlo logical lgchek ! logical first integer num_threads + real (kind=kind_io8) permax, per data first /.true./ save num_threads, first ! - integer len_thread_m, i1_t, i2_t, it - integer num_parthds + integer :: len_thread_m, i1_t, i2_t, it, num_parthds, & + & kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,kminj, & + & ij,nprt,kmaxs,kmins,i + integer :: islimsk(len), iwk(len) ! if (first) then num_threads = num_parthds() first = .false. endif + do it=1,len + islimsk(it) = nint(slimsk(it)) + enddo ! ! check against land-sea mask and ice cover mask ! - if(me .eq. 0) then -! print *,' ' - print *,'performing qc of ',ttl,' mode=',mode, - & '(0=count only, 1=replace)' + if(me == 0) then + print *,'performing qc of ',ttl,' mode=',mode, + & '(0=count only, 1=replace)' endif ! len_thread_m = (len+num_threads-1) / num_threads - kmaxl = 0 - kminl = 0 - kmaxo = 0 - kmino = 0 - kmaxi = 0 - kmini = 0 - kmaxj = 0 - kminj = 0 - kmaxs = 0 - kmins = 0 + + kmaxl = 0 ; kminl = 0 ; kmaxo = 0 ; kmino = 0 + kmaxi = 0 ; kmini = 0 ; kmaxj = 0 ; kminj = 0 + kmaxs = 0 ; kmins = 0 + !$omp parallel do private(i1_t,i2_t,it,i) !$omp+private(nprt,ij,iwk) !$omp+reduction(+:kmaxs,kmins,kmaxl,kminl,kmaxo) !$omp+reduction(+:kmino,kmaxi,kmini,kmaxj,kminj) !$omp+shared(mode,epsfld) !$omp+shared(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn) -!$omp+shared(fld,slimsk,sno,rla,rlo) +!$omp+shared(fld,islimsk,sno,rla,rlo) do it=1,num_threads ! start of threaded loop i1_t = (it-1)*len_thread_m+1 i2_t = min(i1_t+len_thread_m-1,len) @@ -5360,24 +5405,24 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! lower bound check over bare land ! - if (fldlmn .ne. 999.0) then + if (fldlmn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).le.0..and. - & fld(i).lt.fldlmn-epsfld) then - kminl=kminl+1 + if(islimsk(i) == 1 .and. sno(i) <= 0.0 & + & .and. fld(i) < fldlmn-epsfld) then + kminl = kminl + 1 iwk(kminl) = i endif enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then + if(me == 0 .and. it == 1 .and. num_threads == 1) then nprt = min(mmprt,kminl) do i=1,nprt ij = iwk(i) print 8001,rla(ij),rlo(ij),fld(ij),fldlmn - 8001 format(' bare land min. check. lat=',f5.1, + 8001 format(' bare land min. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kminl fld(iwk(i)) = fldlmn enddo @@ -5386,11 +5431,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! upper bound check over bare land ! - if (fldlmx .ne. 999.0) then + if (fldlmx /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).le.0..and. - & fld(i).gt.fldlmx+epsfld) then - kmaxl=kmaxl+1 + if(islimsk(i) == 1 .and. sno(i) <= 0.0 & + & .and. fld(i) > fldlmx+epsfld) then + kmaxl = kmaxl + 1 iwk(kmaxl) = i endif enddo @@ -5399,11 +5444,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, do i=1,nprt ij = iwk(i) print 8002,rla(ij),rlo(ij),fld(ij),fldlmx - 8002 format(' bare land max. check. lat=',f5.1, + 8002 format(' bare land max. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxl fld(iwk(i)) = fldlmx enddo @@ -5412,11 +5457,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! lower bound check over snow covered land ! - if (fldsmn .ne. 999.0) then + if (fldsmn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).gt.0..and. - & fld(i).lt.fldsmn-epsfld) then - kmins=kmins+1 + if(islimsk(i) == 1 .and. sno(i) > 0.0 & + & .and. fld(i) < fldsmn-epsfld) then + kmins = kmins + 1 iwk(kmins) = i endif enddo @@ -5425,11 +5470,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, do i=1,nprt ij = iwk(i) print 8003,rla(ij),rlo(ij),fld(ij),fldsmn - 8003 format(' sno covrd land min. check. lat=',f5.1, + 8003 format(' sno covrd land min. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmins fld(iwk(i)) = fldsmn enddo @@ -5438,11 +5483,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! upper bound check over snow covered land ! - if (fldsmx .ne. 999.0) then + if (fldsmx /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).gt.0..and. - & fld(i).gt.fldsmx+epsfld) then - kmaxs=kmaxs+1 + if(islimsk(i) == 1 .and. sno(i) > 0.0 & + & .and. fld(i) > fldsmx+epsfld) then + kmaxs = kmaxs + 1 iwk(kmaxs) = i endif enddo @@ -5451,11 +5496,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, do i=1,nprt ij = iwk(i) print 8004,rla(ij),rlo(ij),fld(ij),fldsmx - 8004 format(' snow land max. check. lat=',f5.1, + 8004 format(' snow land max. check. lat=',f5.1,i & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxs fld(iwk(i)) = fldsmx enddo @@ -5464,11 +5509,10 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! lower bound check over open ocean ! - if (fldomn .ne. 999.0) then + if (fldomn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.0..and. - & fld(i).lt.fldomn-epsfld) then - kmino=kmino+1 + if(islimsk(i) == 0.0 .and. fld(i) < fldomn-epsfld) then + kmino = kmino + 1 iwk(kmino) = i endif enddo @@ -5477,11 +5521,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, do i=1,nprt ij = iwk(i) print 8005,rla(ij),rlo(ij),fld(ij),fldomn - 8005 format(' open ocean min. check. lat=',f5.1, + 8005 format(' open ocean min. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4,' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmino fld(iwk(i)) = fldomn enddo @@ -5490,24 +5534,23 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! upper bound check over open ocean ! - if (fldomx .ne. 999.0) then + if (fldomx /= 999.0) then do i=i1_t,i2_t - if(fldomx.ne.999..and.slimsk(i).eq.0..and. - & fld(i).gt.fldomx+epsfld) then - kmaxo=kmaxo+1 + if(islimsk(i) ==.0 .and. fld(i) > fldomx+epsfld) then + kmaxo = kmaxo+1 iwk(kmaxo) = i endif enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then + if(me == 0 .and. it == 1 .and. num_threads == 1) then nprt = min(mmprt,kmaxo) do i=1,nprt ij = iwk(i) print 8006,rla(ij),rlo(ij),fld(ij),fldomx - 8006 format(' open ocean max. check. lat=',f5.1, + 8006 format(' open ocean max. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxo fld(iwk(i)) = fldomx enddo @@ -5516,11 +5559,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! lower bound check over sea ice without snow ! - if (fldimn .ne. 999.0) then + if (fldimn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).le.0..and. - & fld(i).lt.fldimn-epsfld) then - kmini=kmini+1 + if(islimsk(i) == 2 .and. sno(i) <= 0.0 & + & .and. fld(i) < fldimn-epsfld) then + kmini = kmini + 1 iwk(kmini) = i endif enddo @@ -5529,11 +5572,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, do i=1,nprt ij = iwk(i) print 8007,rla(ij),rlo(ij),fld(ij),fldimn - 8007 format(' seaice no snow min. check lat=',f5.1, + 8007 format(' seaice no snow min. check lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmini fld(iwk(i)) = fldimn enddo @@ -5542,12 +5585,12 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! upper bound check over sea ice without snow ! - if (fldimx .ne. 999.0) then + if (fldimx /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).le.0..and. - & fld(i).gt.fldimx+epsfld .and. iceflg(i)) then + if(islimsk(i) == 2 .and. sno(i) <= 0.0 .and. & + & fld(i) > fldimx+epsfld .and. iceflg(i)) then ! & fld(i).gt.fldimx+epsfld) then - kmaxi=kmaxi+1 + kmaxi = kmaxi + 1 iwk(kmaxi) = i endif enddo @@ -5556,11 +5599,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, do i=1,nprt ij = iwk(i) print 8008,rla(ij),rlo(ij),fld(ij),fldimx - 8008 format(' seaice no snow max. check lat=',f5.1, + 8008 format(' seaice no snow max. check lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxi fld(iwk(i)) = fldimx enddo @@ -5569,11 +5612,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! lower bound check over sea ice with snow ! - if (fldjmn .ne. 999.0) then + if (fldjmn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).gt.0..and. - & fld(i).lt.fldjmn-epsfld) then - kminj=kminj+1 + if(islimsk(i) == 2 .and. sno(i) > 0.0 .and. & + & fld(i) < fldjmn-epsfld) then + kminj = kminj + 1 iwk(kminj) = i endif enddo @@ -5582,11 +5625,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, do i=1,nprt ij = iwk(i) print 8009,rla(ij),rlo(ij),fld(ij),fldjmn - 8009 format(' sea ice snow min. check lat=',f5.1, + 8009 format(' sea ice snow min. check lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kminj fld(iwk(i)) = fldjmn enddo @@ -5595,12 +5638,12 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! upper bound check over sea ice with snow ! - if (fldjmx .ne. 999.0) then + if (fldjmx /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).gt.0..and. - & fld(i).gt.fldjmx+epsfld .and. iceflg(i)) then + if(islimsk(i) == 2 .and.sno(i) > 0.0 .and. & + & fld(i)> fldjmx+epsfld .and. iceflg(i)) then ! & fld(i).gt.fldjmx+epsfld) then - kmaxj=kmaxj+1 + kmaxj = kmaxj+1 iwk(kmaxj) = i endif enddo @@ -5609,11 +5652,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, do i=1,nprt ij = iwk(i) print 8010,rla(ij),rlo(ij),fld(ij),fldjmx - 8010 format(' seaice snow max check lat=',f5.1, + 8010 format(' seaice snow max check lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxj fld(iwk(i)) = fldjmx enddo @@ -5624,78 +5667,77 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, ! ! print results ! - if(me .eq. 0) then -! write(6,*) 'summary of qc' - permax=0. - if(kminl.gt.0) then - per=float(kminl)/float(len)*100. + if(me == 0) then + permax = 0.0 + if(kminl > 0) then + per = float(kminl)/float(len)*100. print 9001,fldlmn,kminl,per - 9001 format(' bare land min check. modified to ',f8.1, + 9001 format(' bare land min check. modified to ',f8.1, & & ' at ',i5,' points ',f8.1,'percent') - if(per.gt.permax) permax=per + if(per > permax) permax = per endif - if(kmaxl.gt.0) then - per=float(kmaxl)/float(len)*100. + if(kmaxl > 0) then + per = float(kmaxl)/float(len)*100. print 9002,fldlmx,kmaxl,per - 9002 format(' bare land max check. modified to ',f8.1, + 9002 format(' bare land max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmino.gt.0) then - per=float(kmino)/float(len)*100. + if(kmino > 0) then + per = float(kmino)/float(len)*100. print 9003,fldomn,kmino,per - 9003 format(' open ocean min check. modified to ',f8.1, + 9003 format(' open ocean min check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmaxo.gt.0) then - per=float(kmaxo)/float(len)*100. + if(kmaxo > 0) then + per = float(kmaxo)/float(len)*100. print 9004,fldomx,kmaxo,per - 9004 format(' open sea max check. modified to ',f8.1, + 9004 format(' open sea max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmins.gt.0) then - per=float(kmins)/float(len)*100. + if(kmins >.0) then + per = float(kmins)/float(len)*100. print 9009,fldsmn,kmins,per - 9009 format(' snow covered land min check. modified to ',f8.1, + 9009 format(' snow covered land min check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmaxs.gt.0) then - per=float(kmaxs)/float(len)*100. + if(kmaxs > 0) then + per = float(kmaxs)/float(len)*100. print 9010,fldsmx,kmaxs,per - 9010 format(' snow covered land max check. modified to ',f8.1, + 9010 format(' snow covered land max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmini.gt.0) then - per=float(kmini)/float(len)*100. + if(kmini > 0) then + per = float(kmini)/float(len)*100. print 9005,fldimn,kmini,per - 9005 format(' bare ice min check. modified to ',f8.1, + 9005 format(' bare ice min check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmaxi.gt.0) then - per=float(kmaxi)/float(len)*100. + if(kmaxi > 0) then + per = float(kmaxi)/float(len)*100. print 9006,fldimx,kmaxi,per - 9006 format(' bare ice max check. modified to ',f8.1, + 9006 format(' bare ice max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per + if(per > permax) permax=per endif - if(kminj.gt.0) then - per=float(kminj)/float(len)*100. + if(kminj > 0) then + per = float(kminj)/float(len)*100. print 9007,fldjmn,kminj,per - 9007 format(' snow covered ice min check. modified to ',f8.1, + 9007 format(' snow covered ice min check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmaxj.gt.0) then - per=float(kmaxj)/float(len)*100. + if(kmaxj > 0) then + per = float(kmaxj)/float(len)*100. print 9008,fldjmx,kmaxj,per - 9008 format(' snow covered ice max check. modified to ',f8.1, + 9008 format(' snow covered ice max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per + if(per > permax) permax=per endif ! commented on 06/30/99 -- moorthi ! if(lgchek) then @@ -5784,7 +5826,7 @@ subroutine getsmc(wetfld,len,lsoil,smcfld,me) enddo return end - subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, + subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, & & tsfimx) ! use machine , only : kind_io8,kind_io4 @@ -5930,23 +5972,21 @@ subroutine qcsli(slianl,slifcs,len,me) !1111 format(80i1) ! return ! end - subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, - & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, - & zoranl,smcanl, - & smcclm,tsfsmx,albomx,zoromx, me) + subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, & + & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, & + & zoranl,smcanl,smcclm,tsfsmx,albomx,zoromx, me) ! use machine , only : kind_io8,kind_io4 implicit none integer kount,me,k,i,lsoil,len real (kind=kind_io8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx real (kind=kind_io8) tsffcs(len), snofcs(len) - real (kind=kind_io8) snoanl(len), aisanl(len), - & slianl(len), zoranl(len), - & tsfanl(len), albanl(len,4), - & smcanl(len,lsoil) - real (kind=kind_io8) smcclm(len,lsoil) + real (kind=kind_io8) snoanl(len), aisanl(len), & + & slianl(len), zoranl(len), & + & tsfanl(len), albanl(len,4), & + & smcanl(len,lsoil), smcclm(len,lsoil) ! - if (me .eq. 0) write(6,*) 'qc of snow and sea-ice analysis' + if (me == 0) write(6,*) 'qc of snow and sea-ice analysis' ! ! qc of snow analysis ! @@ -5954,7 +5994,7 @@ subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, ! kount = 0 do i=1,len - if(slianl(i).gt.0..and. + if(slianl(i).gt.0..and. & & tsffcs(i).gt.qctsfs.and.snoanl(i).gt.0.) then kount = kount + 1 snoanl(i) = 0. @@ -6026,8 +6066,8 @@ subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, ! return end - subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, - & data,imax,jmax,rlnout,rltout,lmask,rslmsk + subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & + & data,imax,jmax,rlnout,rltout,lmask,rslmsk & &, gaus,blno, blto, kgds1, kpds4, lbms) use machine , only : kind_io8,kind_io4 use sfccyc_module @@ -6507,25 +6547,25 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, ! return end - subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, + subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, & & wlon,rnlat,rlnout,rltout,gaus,blno, blto) use machine , only : kind_io8,kind_io4 implicit none - integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, + integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, & & j,iret - real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, - & rnlat,dxout,dphi,dlat,facns,tem,blno, + real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, & + & rnlat,dxout,dphi,dlat,facns,tem,blno, & & blto ! ! interpolation from lat/lon grid to other lat/lon grid ! - real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) + real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) & &, rlnout(imxout), rltout(jmxout) logical gaus ! real, allocatable :: gaul(:) real (kind=kind_io8) ddx(imxout),ddy(jmxout) - integer iindx1(imxout), iindx2(imxout), + integer iindx1(imxout), iindx2(imxout), & & jindx1(jmxout), jindx2(jmxout) integer jmxsav,n,kspla data jmxsav/0/ @@ -6757,8 +6797,8 @@ subroutine landtyp(vegtype,soiltype,slptype,slmask,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) - +, slptype(len) + real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) & + &, slptype(len) ! ! make sure that the soil type and veg type are non-zero over land ! @@ -6800,7 +6840,7 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) tsfanl(len), tsfan0(len), + real (kind=kind_io8) tsfanl(len), tsfan0(len), & & tsfclm(len), tsfcl0(len) ! ! time interpolation of anomalies @@ -6812,53 +6852,53 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) enddo return end - subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, - & vetclm,sotclm,alfclm, - & vmnclm,vmxclm,slpclm,absclm, - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & deltsfc, lanom - &, imsk, jmsk, slmskh, outlat, outlon - &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb + subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & + & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,& + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & + & fnvetc,fnsotc, & + & fnvmnc,fnvmxc,fnslpc,fnabsc, & + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm,& + & tg3clm,cvclm ,cvbclm,cvtclm, & + & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm,& + & vetclm,sotclm,alfclm, & + & vmnclm,vmxclm,slpclm,absclm, & + & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, & + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & + & kpdvet,kpdsot,kpdalf,tsfcl0, & + & kpdvmn,kpdvmx,kpdslp,kpdabs, & + & deltsfc, lanom & + &, imsk, jmsk, slmskh, outlat, outlon & + &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb & &, tile_num_ch, i_index, j_index) ! use machine , only : kind_io8,kind_io4 implicit none character(len=*), intent(in) :: tile_num_ch integer, intent(in) :: i_index(len), j_index(len) - real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, + real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, & & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2 real (kind=kind_io8) wei1y,wei2y - integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, - & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, - & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, - & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, - & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb + integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, & + & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, & + & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, & + & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, & + & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb & &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat integer kpdalb(4), kpdalf(2) ! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc,fnalbc2 + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & + & fnvetc,fnsotc,fnalbc2 & &, fnvmnc,fnvmxc,fnslpc,fnabsc - real (kind=kind_io8) tsfclm(len),tsfcl2(len), - & wetclm(len),snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len),acnclm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) + real (kind=kind_io8) tsfclm(len),tsfcl2(len), & + & wetclm(len),snoclm(len), & + & zorclm(len),albclm(len,4),aisclm(len), & + & tg3clm(len),acnclm(len), & + & cvclm (len),cvbclm(len),cvtclm(len), & + & cnpclm(len), & + & smcclm(len,lsoil),stcclm(len,lsoil), & + & sliclm(len),scvclm(len),vegclm(len), & + & vetclm(len),sotclm(len),alfclm(len,2) & &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) @@ -7982,8 +8022,8 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, ! return end subroutine clima - subroutine fixrdc_tile(filename_raw, tile_num_ch, - & i_index, j_index, kpds, + subroutine fixrdc_tile(filename_raw, tile_num_ch, & + & i_index, j_index, kpds, & & var, mon, npts, me) use netcdf use machine , only : kind_io8 @@ -8132,15 +8172,17 @@ subroutine netcdf_err(error) call abort end subroutine netcdf_err - subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, - & gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto + + + subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, & + & gdata,len,iret & + &, imsk, jmsk, slmskh, gaus,blno, blto & &, outlat, outlon, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata implicit none - integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, - & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami + integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, & + & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami & &, jj,w3kindreal,w3kindint real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto ! @@ -8308,18 +8350,19 @@ subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, deallocate(lbms) return end subroutine fixrdc - subroutine fixrda(lugb,fngrib,kpds5,slmask, - & iy,im,id,ih,fh,gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto + + subroutine fixrda(lugb,fngrib,kpds5,slmask, & + & iy,im,id,ih,fh,gdata,len,iret & + &, imsk, jmsk, slmskh, gaus,blno, blto & &, outlat, outlon, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata implicit none - integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, - & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, - & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, + integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, & + & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, & + & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, & & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint - real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, + real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, & & rjday,blto ! ! read in grib climatology/analysis files and interpolate to the input From aef879109dac98d986be09363168a6a93f40c76a Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 5 Mar 2020 20:16:14 +0000 Subject: [PATCH 33/91] fixing an openmp error pointed out by Jun wrt z0 --- atmos_model.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index a0204da0a..987608232 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1672,7 +1672,7 @@ subroutine assign_importdata(rc) if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) if (importFieldsValid(findex) .and. IPD_control%cplwav2atm) then -!$omp parallel do default(shared) private(i,j,nb,ix) +!$omp parallel do default(shared) private(i,j,nb,ix,tem) do j=jsc,jec do i=isc,iec nb = Atm_block%blkno(i,j) From cfa5e6b8c7360538a0db678891ed26cbf459a1ab Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 9 Mar 2020 14:12:36 +0000 Subject: [PATCH 34/91] renaming DumpFileds in fv3 cap --- ccpp/physics | 2 +- fv3_cap.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index f8eb82ca3..fd0bc5a5d 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit f8eb82ca3da1e4dfd8665064998ff02279107002 +Subproject commit fd0bc5a5d5baa4bff5c6fb654ed7f52211902e42 diff --git a/fv3_cap.F90 b/fv3_cap.F90 index 1c9136185..2bf718c1d 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -203,7 +203,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return profile_memory = (trim(value)/="false") - call ESMF_AttributeGet(gcomp, name="DumpFields", value=value, defaultValue="false", & + call ESMF_AttributeGet(gcomp, name="DumpFields_ATM", value=value, defaultValue="false", & convention="NUOPC", purpose="Instance", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return From ca0df2f94bfa0d859d8655b0141c032345b7bd0d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 24 Mar 2020 19:54:03 -0400 Subject: [PATCH 35/91] updted gitmodules --- .gitmodules | 2 +- atmos_cubed_sphere | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 04f33a38b..2827f0fee 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,4 +9,4 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics - branch = SM_Jan102020 + branch = SM_Mar032020 diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index db3acfbec..371a29afb 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit db3acfbec2ca00d1795b72b7ebf0b1e308506ced +Subproject commit 371a29afbf813357dd93647cac0cbcd44db2ab20 From f3c9323854cd144a485deb1329b2bc28bb16ecda Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 15 Apr 2020 18:01:09 +0000 Subject: [PATCH 36/91] updating constants to real 8 and a bug fix in MG driver --- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 228 +++++---- gfsphysics/GFS_layer/GFS_radiation_driver.F90 | 102 ++-- gfsphysics/physics/gcm_shoc.f90 | 41 +- gfsphysics/physics/get_prs.f | 102 ++-- gfsphysics/physics/m_micro_driver.F90 | 471 +++++++++--------- gfsphysics/physics/micro_mg3_0.F90 | 18 +- gfsphysics/physics/micro_mg_utils.F90 | 52 +- gfsphysics/physics/moninshoc.f | 111 +++-- gfsphysics/physics/rascnvv2.f | 360 ++++++------- gfsphysics/physics/sfc_drv.f | 10 +- gfsphysics/physics/sfc_ocean.f | 21 +- 11 files changed, 773 insertions(+), 743 deletions(-) diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 9cd0df74a..3b02a4e80 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -17,7 +17,8 @@ module module_physics_driver GFS_sfcprop_type, GFS_coupling_type, & GFS_control_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type, huge + GFS_radtend_type, GFS_diag_type +! GFS_radtend_type, GFS_diag_type, huge use gfdl_cloud_microphys_mod, only: gfdl_cloud_microphys_driver, & cloud_diagnosis use module_mp_thompson, only: mp_gt_driver @@ -54,11 +55,12 @@ module module_physics_driver real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0, & half = 0.5d0, onebg = one/con_g real(kind=kind_phys), parameter :: albdf = 0.06d0 - real(kind=kind_phys), parameter :: tf=258.16d0, tcr=273.16d0, tcrf=1.0/(tcr-tf) + real(kind=kind_phys), parameter :: tf=258.16d0, tcr=273.16d0, tcrf=one/(tcr-tf) real(kind=kind_phys), parameter :: con_p001= 0.001d0 real(kind=kind_phys), parameter :: con_day = 86400.0d0 real(kind=kind_phys), parameter :: rad2dg = 180.0d0/con_pi real(kind=kind_phys), parameter :: omz1 = 10.0d0 + real(kind=kind_phys), parameter :: huge = zero !> GFS Physics Implementation Layer !> @brief Layer that invokes individual GFS physics routines @@ -1040,7 +1042,7 @@ subroutine GFS_physics_driver & !## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run do i = 1, IM - sigmaf(i) = max( Sfcprop%vfrac(i),0.01 ) + sigmaf(i) = max( Sfcprop%vfrac(i),0.01d0 ) islmsk(i) = nint(Sfcprop%slmsk(i)) if (islmsk(i) == 2) then @@ -1125,44 +1127,62 @@ subroutine GFS_physics_driver & if (fice(i) >= Model%min_seaice) then icy(i) = .true. else - fice(i) = zero + wet(i) = .true. + fice(i) = zero + flag_cice(i) = .false. + islmsk_cice(i) = 0 + islmsk(i) = 0 endif else if (fice(i) >= Model%min_lakeice) then icy(i) = .true. else - fice(i) = zero + wet(i) = .true. + fice(i) = zero + islmsk(i) = 0 endif endif if (fice(i) < one) then - wet(i)=.true. ! some open ocean/lake water exists - if (.not. Model%cplflx) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) - end if + wet(i) = .true. ! some open ocean/lake water exists + if (.not. Model%cplflx .or. Sfcprop%oceanfrac(i) == zero) & + Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) + endif else fice(i) = zero endif enddo else do i = 1, IM - frland(i) = zero - if (islmsk(i) == 0) then -! Sfcprop%tsfco(i) = Sfcprop%tsfc(i) - wet(i) = .true. - fice(i) = zero - elseif (islmsk(i) == 1) then + if (islmsk(i) == 1) then ! Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) dry(i) = .true. frland(i) = one fice(i) = zero else - fice(i) = Sfcprop%fice(i) - icy(i) = .true. + frland(i) = zero + if (flag_cice(i)) then + if (fice(i) > Model%min_seaice) then + icy(i) = .true. + else + wet(i) = .true. + fice(i) = zero + flag_cice(i) = .false. + islmsk_cice(i) = 0 + islmsk(i) = 0 + endif + else + if (fice(i) > Model%min_lakeice) then + icy(i) = .true. + else + wet(i) = .true. + fice(i) = zero + islmsk(i) = 0 + endif + endif if (fice(i) < one) then - wet(i) = .true. -! Sfcprop%tsfco(i) = tgice - if (.not. Model%cplflx) Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) -! Sfcprop%tsfco(i) = max((Sfcprop%tsfc(i) - fice(i)*sfcprop%tisfc(i)) & -! / (one - fice(i)), tgice) + wet(i)=.true. ! some open ocean/lake water exists + if (.not. Model%cplflx .or. Sfcprop%oceanfrac(i) == zero) & + Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) endif endif enddo @@ -1499,7 +1519,7 @@ subroutine GFS_physics_driver & do i=1,im if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg tem1 = adjsfcdsw(i) / xcosz(i) - if ( tem1 >= 120.0 ) then + if ( tem1 >= 120.0d0 ) then Diag%suntim(i) = Diag%suntim(i) + dtf endif endif @@ -1581,8 +1601,8 @@ subroutine GFS_physics_driver & kinver(i) = levs !## CCPP ## GFS_typedefs.F90/interstitial_phys_reset invrsn(i) = .false. tx1(i) = zero - tx2(i) = 10.0 - ctei_r(i) = 10.0 + tx2(i) = 10.0d0 + ctei_r(i) = 10.0d0 enddo ! Only used for old shallow convection with mstrat=.true. @@ -1592,12 +1612,12 @@ subroutine GFS_physics_driver & ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) do k=1,levs/2 do i=1,im - if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35*Statein%prsi(i,1) & + if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35d0*Statein%prsi(i,1) & .and. (.not. invrsn(i))) then tem = (Statein%tgrs(i,k+1) - Statein%tgrs(i,k)) & / (Statein%prsl(i,k) - Statein%prsl(i,k+1)) - if (((tem > 0.00010) .and. (tx1(i) < zero)) .or. & + if (((tem > 0.00010d0) .and. (tx1(i) < zero)) .or. & ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then invrsn(i) = .true. @@ -1611,7 +1631,7 @@ subroutine GFS_physics_driver & ctei_r(i) = (one/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & + Statein%qgrs(i,k+1,ntcw)-Statein%qgrs(i,k,ntcw)) else - ctei_r(i) = 10 + ctei_r(i) = 10.0d0 endif if ( ctei_rml(i) > ctei_r(i) ) then @@ -1654,7 +1674,7 @@ subroutine GFS_physics_driver & Diag%smcref2(i) = zero wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) + + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0d0)), one) !*## CCPP ## enddo !*## CCPP ## @@ -1690,7 +1710,7 @@ subroutine GFS_physics_driver & !*## CCPP ## !## CCPP ##* GFS_surface_loop_control/GFS_surface_loop_control_part1_run do i=1,im - if (iter == 1 .and. wind(i) < 2.0) then + if (iter == 1 .and. wind(i) < 2.0d0) then flag_guess(i) = .true. endif enddo @@ -1764,8 +1784,8 @@ subroutine GFS_physics_driver & ! --- ... run nsst model ... --- if (Model%nstf_name(1) > 1) then - zsea1 = 0.001*real(Model%nstf_name(4)) - zsea2 = 0.001*real(Model%nstf_name(5)) + zsea1 = 0.001d0*real(Model%nstf_name(4)) + zsea2 = 0.001d0*real(Model%nstf_name(5)) call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & Sfcprop%z_c, wet, zsea1, zsea2, im, 1, dtzm) do i=1,im @@ -1993,7 +2013,7 @@ subroutine GFS_physics_driver & flag_iter(i) = .false. flag_guess(i) = .false. - if (iter == 1 .and. wind(i) < 2.0) then + if (iter == 1 .and. wind(i) < 2.0d0) then ! if (dry(i) .or. (wet(i) .and. .not.icy(i) & if (dry(i) .or. (wet(i) .and. Model%nstf_name(1) > 0)) then flag_iter(i) = .true. @@ -2126,22 +2146,23 @@ subroutine GFS_physics_driver & Sfcprop%zorll(i) = zorl3(i,1) Sfcprop%zorlo(i) = zorl3(i,3) - if (flag_cice(i) .and. wet(i)) then ! this was already done for lake ice in sfc_sice - txi = fice(i) - txo = one - txi - evap(i) = txi * evap3(i,2) + txo * evap3(i,3) - hflx(i) = txi * hflx3(i,2) + txo * hflx3(i,3) - Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) - else ! return updated lake ice thickness & concentration to global array - if (islmsk(i) == 2) then - Sfcprop%hice(i) = zice(i) - Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen - Sfcprop%tisfc(i) = tice(i) - else ! this would be over open ocean or land (no ice fraction) - Sfcprop%hice(i) = zero - Sfcprop%fice(i) = zero - Sfcprop%tisfc(i) = Sfcprop%tsfc(i) + if (flag_cice(i)) then + if (wet(i)) then ! this was already done for lake ice in sfc_sice + txi = fice(i) + txo = one - txi + evap(i) = txi * evap3(i,2) + txo * evap3(i,3) + hflx(i) = txi * hflx3(i,2) + txo * hflx3(i,3) + Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) endif + elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array + Sfcprop%hice(i) = zice(i) + Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen + Sfcprop%tisfc(i) = tice(i) + else ! this would be over open ocean or land (no ice fraction) + Sfcprop%hice(i) = zero + Sfcprop%fice(i) = zero + Sfcprop%tisfc(i) = Sfcprop%tsfc(i) + icy(i) = .false. endif enddo endif ! if (Model%frac_grid) @@ -2234,11 +2255,11 @@ subroutine GFS_physics_driver & if (wet(i)) then ! some open water ! --- compute open water albedo xcosz_loc = max( zero, min( one, xcosz(i) )) - ocalnirdf_cpl(i) = 0.06 - ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & - & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & + ocalnirdf_cpl(i) = 0.06d0 + ocalnirbm_cpl(i) = max(albdf, 0.026d0/(xcosz_loc**1.7d0+0.065d0) & + & + 0.15d0 * (xcosz_loc-0.1d0) * (xcosz_loc-0.5d0) & & * (xcosz_loc-one)) - ocalvisdf_cpl(i) = 0.06 + ocalvisdf_cpl(i) = 0.06d0 ocalvisbm_cpl(i) = ocalnirbm_cpl(i) Coupling%nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl(i)) @@ -3074,7 +3095,7 @@ subroutine GFS_physics_driver & if (ntke > 0) then tke(1:im,:) = Statein%qgrs(1:im,:,ntke) + dqdt(1:im,:,ntke) * dtp else - tke(:,:) = -9999.0 + tke(:,:) = -9999.0d0 endif ! ! tendency without PBL-accumulations @@ -3351,7 +3372,7 @@ subroutine GFS_physics_driver & do k=1,levs do i=1,im clw(i,k,1) = zero - clw(i,k,2) = -999.9 + clw(i,k,2) = -999.9d0 enddo enddo @@ -3420,7 +3441,7 @@ subroutine GFS_physics_driver & !## CCPP ## GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run if (ntcw > 0) then ! if (imp_physics == Model%imp_physics_mg .and. .not. Model%do_shoc) then ! compute rhc for GMAO macro physics cloud pdf - if (imp_physics == Model%imp_physics_mg .and. Model%crtrh(2) < 0.5) then ! compute rhc for GMAO macro physics cloud pdf + if (imp_physics == Model%imp_physics_mg .and. Model%crtrh(2) < 0.5d0) then ! compute rhc for GMAO macro physics cloud pdf do i=1,im tx1(i) = one / Statein%prsi(i,1) tx2(i) = one - rhc_max*work1(i) - Model%crtrh(1)*work2(i) @@ -3879,7 +3900,7 @@ subroutine GFS_physics_driver & do k=1,levs kk = min(k+1,levs) ! assuming no cloud top reaches the model top do i=1,im !DD - sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + sigmafrac(i,k) = 0.5d0 * (sigmatot(i,k)+sigmatot(i,kk)) enddo enddo endif @@ -3905,7 +3926,7 @@ subroutine GFS_physics_driver & enddo else do i=1,im - ccwfac(i) = -999.0 + ccwfac(i) = -999.0d0 dlqfac(i) = zero psaur_l(i) = Model%psauras(1)*work1(i) + Model%psauras(2)*work2(i) praur_l(i) = Model%prauras(1)*work1(i) + Model%prauras(2)*work2(i) @@ -3925,8 +3946,8 @@ subroutine GFS_physics_driver & revap = .true. ! if (ncld ==2) revap = .false. - trcmin(:) = -999999.0 - if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4 + trcmin(:) = -999999.0d0 + if (ntk-2 > 0) trcmin(ntk-2) = 1.0d-4 !*## CCPP ## ! if (lprnt) write(0,*)' gt04bras=',Stateout%gt0(ipr,:) ! if (lprnt) write(0,*)' gq04bras=',Stateout%gq0(ipr,:,1) @@ -4237,10 +4258,10 @@ subroutine GFS_physics_driver & do k=1,levs do i=1,im - eng0 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + eng0 = 0.5d0*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp - eng1 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + eng1 = 0.5d0*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) Stateout%gt0(i,k) = Stateout%gt0(i,k) + (eng0-eng1)/(dtp*con_cp) enddo ! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', @@ -4385,7 +4406,7 @@ subroutine GFS_physics_driver & levshc(:) = 0 do k=2,levs do i=1,im - dpshc = 0.3 * Statein%prsi(i,1) + dpshc = 0.3d0 * Statein%prsi(i,1) if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k enddo enddo @@ -4436,7 +4457,7 @@ subroutine GFS_physics_driver & ! do k=1,levs do i=1,im - if (clw(i,k,2) <= -999.0) clw(i,k,2) = zero + if (clw(i,k,2) <= -999.0d0) clw(i,k,2) = zero enddo enddo !*## CCPP ## @@ -5172,8 +5193,8 @@ subroutine GFS_physics_driver & if (Model%effr_in) then do i =1, im - den(i,k) = 0.622*Statein%prsl(i,k) / & - (con_rd*Stateout%gt0(i,k)*(Stateout%gq0(i,k,1)+0.622)) + den(i,k) = 0.622d0*Statein%prsl(i,k) / & + (con_rd*Stateout%gt0(i,k)*(Stateout%gq0(i,k,1)+0.622d0)) enddo endif enddo @@ -5188,8 +5209,8 @@ subroutine GFS_physics_driver & call max_fields(Statein%phil,Diag%refl_10cm,con_g,im,levs,refd,Stateout%gt0,refd263k) if (reset) then do i=1,im - Diag%refdmax(I) = -35. - Diag%refdmax263k(I) = -35. + Diag%refdmax(I) = -35.0d0 + Diag%refdmax263k(I) = -35.0d0 enddo endif do i=1,im @@ -5355,33 +5376,6 @@ subroutine GFS_physics_driver & endif - if (Model%lssav) then -! if (Model%me == 0) print *,'in phys drive, kdt=',Model%kdt, & -! 'totprcpb=', Diag%totprcpb(1),'totprcp=',Diag%totprcp(1), & -! 'rain=',Diag%rain(1) - do i=1,im - Diag%cnvprcp(i) = Diag%cnvprcp(i) + Diag%rainc(i) - Diag%totprcp (i) = Diag%totprcp (i) + Diag%rain(i) - Diag%totice (i) = Diag%totice (i) + Diag%ice(i) - Diag%totsnw (i) = Diag%totsnw (i) + Diag%snow(i) - Diag%totgrp (i) = Diag%totgrp (i) + Diag%graupel(i) -! - Diag%cnvprcpb(i) = Diag%cnvprcpb(i) + Diag%rainc(i) - Diag%totprcpb(i) = Diag%totprcpb(i) + Diag%rain(i) - Diag%toticeb (i) = Diag%toticeb (i) + Diag%ice(i) - Diag%totsnwb (i) = Diag%totsnwb (i) + Diag%snow(i) - Diag%totgrpb (i) = Diag%totgrpb (i) + Diag%graupel(i) - enddo - - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - Diag%dt3dt(i,k,6) = Diag%dt3dt(i,k,6) + (Stateout%gt0(i,k)-dtdt(i,k)) * frain -! Diag%dq3dt(i,k,4) = Diag%dq3dt(i,k,4) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain - enddo - enddo - endif - endif !*## CCPP ## !## CCPP ##* this block not yet in CCPP !-------------------------------- @@ -5446,14 +5440,21 @@ subroutine GFS_physics_driver & enddo elseif( .not. Model%cal_pre) then if (Model%imp_physics == Model%imp_physics_mg) then ! MG microphysics - tem = con_day / (dtp * con_p001) ! mm / day do i=1,im - Sfcprop%tprcp(i) = max(zero, Diag%rain(i) ) ! clu: rain -> tprcp - if (Diag%rain(i)*tem > rainmin) then - Sfcprop%srflag(i) = max(zero, min(one, (Diag%rain(i)-Diag%rainc(i))*Diag%sr(i)/Diag%rain(i))) + if (Diag%rain(i) > rainmin) then + tem1 = max(zero, (Diag%rain(i)-Diag%rainc(i))) * Diag%sr(i) + tem2 = one / Diag%rain(i) + if (t850(i) > 273.16d0) then + Sfcprop%srflag(i) = max(zero, min(one, tem1*tem2)) + else + Sfcprop%srflag(i) = max(zero, min(one, (tem1+Diag%rainc(i))*tem2)) + endif else Sfcprop%srflag(i) = zero + Diag%rain(i) = zero + Diag%rainc(i) = zero endif + Sfcprop%tprcp(i) = max(zero, Diag%rain(i) ) ! clu: rain -> tprcp enddo else do i = 1, im @@ -5466,13 +5467,40 @@ subroutine GFS_physics_driver & endif endif + if (Model%lssav) then +! if (Model%me == 0) print *,'in phys drive, kdt=',Model%kdt, & +! 'totprcpb=', Diag%totprcpb(1),'totprcp=',Diag%totprcp(1), & +! 'rain=',Diag%rain(1) + do i=1,im + Diag%cnvprcp(i) = Diag%cnvprcp(i) + Diag%rainc(i) + Diag%totprcp (i) = Diag%totprcp (i) + Diag%rain(i) + Diag%totice (i) = Diag%totice (i) + Diag%ice(i) + Diag%totsnw (i) = Diag%totsnw (i) + Diag%snow(i) + Diag%totgrp (i) = Diag%totgrp (i) + Diag%graupel(i) +! + Diag%cnvprcpb(i) = Diag%cnvprcpb(i) + Diag%rainc(i) + Diag%totprcpb(i) = Diag%totprcpb(i) + Diag%rain(i) + Diag%toticeb (i) = Diag%toticeb (i) + Diag%ice(i) + Diag%totsnwb (i) = Diag%totsnwb (i) + Diag%snow(i) + Diag%totgrpb (i) = Diag%totgrpb (i) + Diag%graupel(i) + enddo + + if (Model%ldiag3d) then + do k=1,levs + do i=1,im + Diag%dt3dt(i,k,6) = Diag%dt3dt(i,k,6) + (Stateout%gt0(i,k)-dtdt(i,k)) * frain +! Diag%dq3dt(i,k,4) = Diag%dq3dt(i,k,4) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + enddo + enddo + endif + endif ! --- ... coupling insertion if (Model%cplflx .or. Model%cplchm) then do i = 1, im - Tbd%dsnow_cpl(i)= Diag%rain(i) * Sfcprop%srflag(i) - Tbd%drain_cpl(i)= Diag%rain(i) - Tbd%dsnow_cpl(i) + Tbd%dsnow_cpl(i)= max(zero, Diag%rain(i) * Sfcprop%srflag(i)) + Tbd%drain_cpl(i)= max(zero, Diag%rain(i) - Tbd%dsnow_cpl(i)) Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Tbd%drain_cpl(i) Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Tbd%dsnow_cpl(i) enddo @@ -5644,7 +5672,7 @@ subroutine GFS_physics_driver & Diag%u10max(i) = Diag%u10m(i) Diag%v10max(i) = Diag%v10m(i) endif - pshltr = Statein%pgr(i)*exp(-0.068283/Stateout%gt0(i,1)) + pshltr = Statein%pgr(i)*exp(-0.068283d0/Stateout%gt0(i,1)) QCQ = PQ0/pshltr*EXP(A2A*(Sfcprop%t2m(i)-A3)/(Sfcprop%t2m(i)-A4)) rh02 = Sfcprop%q2m(i) / QCQ IF (rh02 > one) THEN diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 index d9190c3b3..4fd9c18cd 100644 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 @@ -377,11 +377,11 @@ module module_radiation_driver ! !> EPSQ=1.0e-12 real (kind=kind_phys) :: EPSQ ! parameter (QMIN=1.0e-10, QME5=1.0e-5, QME6=1.0e-6, EPSQ=1.0e-12) - parameter (QMIN=1.0e-10, QME5=1.0e-7, QME6=1.0e-7, EPSQ=1.0e-12) + parameter (QMIN=1.0d-10, QME5=1.0d-7, QME6=1.0d-7, EPSQ=1.0d-12) ! parameter (QMIN=1.0e-10, QME5=1.0e-20, QME6=1.0e-20, EPSQ=1.0e-12) !> lower limit of toa pressure value in mb - real, parameter :: prsmin = 1.0e-6 + real, parameter :: prsmin = 1.0d-6 !> control flag for LW surface temperature at air/ground interface !! (default=0, the value will be set in subroutine radinit) @@ -1247,6 +1247,8 @@ subroutine GFS_radiation_driver & real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtausw real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtaulw + real(kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 + !--- TYPED VARIABLES type (cmpfsw_type), dimension(size(Grid%xlon,1)) :: scmpsw @@ -1340,15 +1342,15 @@ subroutine GFS_radiation_driver & k1 = k + kd k2 = k + lsk do i = 1, IM - plvl(i,k1+kb) = Statein%prsi(i,k2+kb) * 0.01 ! pa to mb (hpa) - plyr(i,k1) = Statein%prsl(i,k2) * 0.01 ! pa to mb (hpa) + plvl(i,k1+kb) = Statein%prsi(i,k2+kb) * 0.01d0 ! pa to mb (hpa) + plyr(i,k1) = Statein%prsl(i,k2) * 0.01d0 ! pa to mb (hpa) tlyr(i,k1) = Statein%tgrs(i,k2) prslk1(i,k1) = Statein%prslk(i,k2) !> - Compute relative humidity. es = min( Statein%prsl(i,k2), fpvs( Statein%tgrs(i,k2) ) ) ! fpvs and prsl in pa qs = max( QMIN, eps * es / (Statein%prsl(i,k2) + epsm1*es) ) - rhly(i,k1) = max( 0.0, min( 1.0, max(QMIN, Statein%qgrs(i,k2,1))/qs ) ) + rhly(i,k1) = max( zero, min( one, max(QMIN, Statein%qgrs(i,k2,1))/qs ) ) qstl(i,k1) = qs enddo enddo @@ -1358,7 +1360,7 @@ subroutine GFS_radiation_driver & do k = 1, LM k1 = k + kd k2 = k + lsk - tracer1(:,k1,j) = max(0.0, Statein%qgrs(:,k2,j)) + tracer1(:,k1,j) = max(zero, Statein%qgrs(:,k2,j)) enddo enddo ! @@ -1367,18 +1369,18 @@ subroutine GFS_radiation_driver & k1 = 1 + kd k2 = k1 + kb do i = 1, IM - plvl(i,k2) = 0.01 * Statein%prsi(i,1+kb) ! pa to mb (hpa) - plyr(i,k1) = 0.5 * (plvl(i,k2+1) + plvl(i,k2)) - prslk1(i,k1) = (plyr(i,k1)*0.001) ** rocp + plvl(i,k2) = 0.01d0 * Statein%prsi(i,1+kb) ! pa to mb (hpa) + plyr(i,k1) = 0.5d0 * (plvl(i,k2+1) + plvl(i,k2)) + prslk1(i,k1) = (plyr(i,k1)*0.001d0) ** rocp enddo endif else ! input data from sfc to top if (Model%levs > lm) then k1 = lm + kd do i = 1, IM - plvl(i,k1+1) = 0.01 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) - plyr(i,k1) = 0.5 * (plvl(i,k1+1) + plvl(i,k1)) - prslk1(i,k1) = (plyr(i,k1)*0.001) ** rocp + plvl(i,k1+1) = 0.01d0 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) + plyr(i,k1) = 0.5d0 * (plvl(i,k1+1) + plvl(i,k1)) + prslk1(i,k1) = (plyr(i,k1)*0.001d0) ** rocp enddo endif endif @@ -1386,10 +1388,10 @@ subroutine GFS_radiation_driver & if ( lextop ) then ! values for extra top layer do i = 1, IM plvl(i,llb) = prsmin - if ( plvl(i,lla) <= prsmin ) plvl(i,lla) = 2.0*prsmin - plyr(i,lyb) = 0.5 * plvl(i,lla) + if ( plvl(i,lla) <= prsmin ) plvl(i,lla) = 2.0d0*prsmin + plyr(i,lyb) = 0.5d0 * plvl(i,lla) tlyr(i,lyb) = tlyr(i,lya) - prslk1(i,lyb) = (plyr(i,lyb)*0.001) ** rocp ! plyr in Pa + prslk1(i,lyb) = (plyr(i,lyb)*0.001d0) ** rocp ! plyr in Pa rhly(i,lyb) = rhly(i,lya) qstl(i,lyb) = qstl(i,lya) enddo @@ -1461,7 +1463,7 @@ subroutine GFS_radiation_driver & do i = 1, IM qlyr(i,k1) = max( tem1d(i), Statein%qgrs(i,k,1) ) tem1d(i) = min( QME5, qlyr(i,k1) ) - tvly(i,k1) = Statein%tgrs(i,k) * (1.0 + fvirt*qlyr(i,k1)) ! virtual T (K) + tvly(i,k1) = Statein%tgrs(i,k) * (one + fvirt*qlyr(i,k1)) ! virtual T (K) delp(i,k1) = plvl(i,k1+1) - plvl(i,k1) enddo enddo @@ -1484,7 +1486,7 @@ subroutine GFS_radiation_driver & ! --- ... level height and layer thickness (km) - tem0d = 0.001 * rog + tem0d = 0.001d0 * rog do i = 1, IM do k = 1, LMK dz(i,k) = tem0d * (tem2db(i,k+1) - tem2db(i,k)) * tvly(i,k) @@ -1512,7 +1514,7 @@ subroutine GFS_radiation_driver & do i = 1, IM qlyr(i,k) = max( tem1d(i), Statein%qgrs(i,k,1) ) tem1d(i) = min( QME5, qlyr(i,k) ) - tvly(i,k) = Statein%tgrs(i,k) * (1.0 + fvirt*qlyr(i,k)) ! virtual T (K) + tvly(i,k) = Statein%tgrs(i,k) * (one + fvirt*qlyr(i,k)) ! virtual T (K) delp(i,k) = plvl(i,k) - plvl(i,k+1) enddo enddo @@ -1535,7 +1537,7 @@ subroutine GFS_radiation_driver & ! --- ... level height and layer thickness (km) - tem0d = 0.001 * rog + tem0d = 0.001d0 * rog do i = 1, IM do k = LMK, 1, -1 dz(i,k) = tem0d * (tem2db(i,k) - tem2db(i,k+1)) * tvly(i,k) @@ -1553,7 +1555,7 @@ subroutine GFS_radiation_driver & !## CCPP ##* rrtmg_sw_pre.F90/rrtmg_sw_pre_run nday = 0 do i = 1, IM - if (Radtend%coszen(i) >= 0.0001) then + if (Radtend%coszen(i) >= 0.0001d0) then nday = nday + 1 idxday(nday) = i endif @@ -1582,7 +1584,7 @@ subroutine GFS_radiation_driver & ! --- ... obtain cloud information for radiation calculations ! if (ntcw > 0) then ! prognostic cloud schemes - ccnd = 0.0_kind_phys + ccnd = zero if (Model%ncnd == 1) then ! Zhao_Carr_Sundqvist do k=1,LMK do i=1,IM @@ -1618,7 +1620,7 @@ subroutine GFS_radiation_driver & do n=1,ncndl do k=1,LMK do i=1,IM - if (ccnd(i,k,n) < epsq) ccnd(i,k,n) = 0.0 + if (ccnd(i,k,n) < epsq) ccnd(i,k,n) = zero enddo enddo enddo @@ -1646,7 +1648,7 @@ subroutine GFS_radiation_driver & endif do k=1,LMK do i=1,IM - if (ccnd(i,k,1) < EPSQ ) ccnd(i,k,1) = 0.0 + if (ccnd(i,k,1) < EPSQ ) ccnd(i,k,1) = zero enddo enddo endif @@ -1696,7 +1698,7 @@ subroutine GFS_radiation_driver & endif else ! neither of the other two cases - cldcov = 0.0 + cldcov = zero endif ! @@ -1719,17 +1721,17 @@ subroutine GFS_radiation_driver & do k=1,lm k1 = k + kd do i=1,im - deltaq(i,k1) = 0.0 + deltaq(i,k1) = zero cnvw (i,k1) = Tbd%phy_f3d(i,k,Model%num_p3d+1) - cnvc (i,k1) = 0.0 + cnvc (i,k1) = zero enddo enddo else ! all the rest do k=1,lmk do i=1,im - deltaq(i,k) = 0.0 - cnvw (i,k) = 0.0 - cnvc (i,k) = 0.0 + deltaq(i,k) = zero + cnvw (i,k) = zero + cnvc (i,k) = zero enddo enddo endif @@ -1811,9 +1813,9 @@ subroutine GFS_radiation_driver & elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6) then ! Thompson / WSM6 cloud micrphysics scheme if (Model%kdt == 1) then - Tbd%phy_f3d(:,:,1) = 10. - Tbd%phy_f3d(:,:,2) = 50. - Tbd%phy_f3d(:,:,3) = 250. + Tbd%phy_f3d(:,:,1) = 10.0d0 + Tbd%phy_f3d(:,:,2) = 50.0d0 + Tbd%phy_f3d(:,:,3) = 250.0d0 endif call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs @@ -1838,9 +1840,9 @@ subroutine GFS_radiation_driver & ! --- scale random patterns for surface perturbations with ! perturbation size ! --- turn vegetation fraction pattern into percentile pattern - alb1d(:) = 0. + alb1d(:) = zero if (Model%do_sfcperts) then - if (Model%pertalb(1) > 0.) then + if (Model%pertalb(1) > zero) then do i=1,im call cdfnor(Coupling%sfc_wts(i,5),alb1d(i)) enddo @@ -1866,7 +1868,7 @@ subroutine GFS_radiation_driver & sfcalb) ! --- outputs !> -# Approximate mean surface albedo from vis- and nir- diffuse values. - Radtend%sfalb(:) = max(0.01, 0.5 * (sfcalb(:,2) + sfcalb(:,4))) + Radtend%sfalb(:) = max(0.01d0, 0.5d0 * (sfcalb(:,2) + sfcalb(:,4))) !*## CCPP ## !## CCPP ##* radsw_main.f/rrtmg_sw_run; Note: The checks for nday and lsswr are included in the scheme (returns if @@ -1942,26 +1944,26 @@ subroutine GFS_radiation_driver & else ! if_nday_block - Radtend%htrsw(:,:) = 0.0 + Radtend%htrsw(:,:) = zero Radtend%sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) Diag%topfsw = topfsw_type( 0.0, 0.0, 0.0 ) scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) do i=1,im - Coupling%nirbmdi(i) = 0.0 - Coupling%nirdfdi(i) = 0.0 - Coupling%visbmdi(i) = 0.0 - Coupling%visdfdi(i) = 0.0 - - Coupling%nirbmui(i) = 0.0 - Coupling%nirdfui(i) = 0.0 - Coupling%visbmui(i) = 0.0 - Coupling%visdfui(i) = 0.0 + Coupling%nirbmdi(i) = zero + Coupling%nirdfdi(i) = zero + Coupling%visbmdi(i) = zero + Coupling%visdfdi(i) = zero + + Coupling%nirbmui(i) = zero + Coupling%nirdfui(i) = zero + Coupling%visbmui(i) = zero + Coupling%visdfui(i) = zero enddo if (Model%swhtr) then - Radtend%swhc(:,:) = 0.0 + Radtend%swhc(:,:) = zero endif endif ! end_if_nday @@ -2084,7 +2086,7 @@ subroutine GFS_radiation_driver & ! part of sw calling interval, while coszdg= mean cosz over entire interval if (Model%lsswr) then do i = 1, IM - if (Radtend%coszen(i) > 0.) then + if (Radtend%coszen(i) > zero) then ! --- sw total-sky fluxes ! ------------------- tem0d = Model%fhswr * Radtend%coszdg(i) / Radtend%coszen(i) @@ -2144,7 +2146,7 @@ subroutine GFS_radiation_driver & tem0d = raddt * cldsa(i,j) itop = mtopa(i,j) - kd ibtc = mbota(i,j) - kd - tem1 = 0. + tem1 = zero do k=ibtc,itop tem1 = tem1 + cldtausw(i,k) ! approx .55 um channel enddo @@ -2159,11 +2161,11 @@ subroutine GFS_radiation_driver & tem0d = raddt * cldsa(i,j) itop = mtopa(i,j) - kd ibtc = mbota(i,j) - kd - tem2 = 0. + tem2 = zero do k=ibtc,itop tem2 = tem2 + cldtaulw(i,k) ! approx 10. um channel enddo - Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) + Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (one-exp(-tem2)) enddo enddo endif diff --git a/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 index f5791a049..fa6133899 100644 --- a/gfsphysics/physics/gcm_shoc.f90 +++ b/gfsphysics/physics/gcm_shoc.f90 @@ -484,7 +484,7 @@ subroutine tke_shoc() call eddy_length() ! Find turbulent mixing length call check_eddy() ! Make sure it's reasonable - tkef2 = 1.0 - tkef1 + tkef2 = one - tkef1 do k=1,nzm ku = k+1 kd = k @@ -528,7 +528,7 @@ subroutine tke_shoc() !Obtain Brunt-Vaisalla frequency from diagnosed SGS buoyancy flux !Presumably it is more precise than BV freq. calculated in eddy_length()? - buoy_sgs = - (a_prod_bu+a_prod_bu) / (tkh(i,ku)+tkh(i,kd) + 0.0001) ! tkh is eddy thermal diffussivity + buoy_sgs = - (a_prod_bu+a_prod_bu) / (tkh(i,ku)+tkh(i,kd) + 0.0001d0) ! tkh is eddy thermal diffussivity !Compute $c_k$ (variable Cee) for the TKE dissipation term following Deardorff (1980) @@ -732,7 +732,7 @@ subroutine eddy_length() ! Find the in-cloud Brunt-Vaisalla frequency - omn = qcl(i,k) / (wrk+1.e-20) ! Ratio of liquid water to total water + omn = qcl(i,k) / (wrk+1.0d-20) ! Ratio of liquid water to total water ! Latent heat of phase transformation based on relative water phase content ! fac_cond = lcond/cp, fac_fus = lfus/cp @@ -877,7 +877,7 @@ subroutine eddy_length() enddo conv_var = conv_var ** oneb3 - if (conv_var > 0) then ! If convective vertical velocity scale > 0 + if (conv_var > zero) then ! If convective vertical velocity scale > 0 depth = (zl(i,ku)-zl(i,kl)) + adzl(i,kl) @@ -937,7 +937,7 @@ subroutine conv_scale() !********************************************************************** conv_vel2(i,k) = conv_vel2(i,k-1) & - + 2.5*adzi(i,k)*bet(i,k)*wthv_sec(i,k) + + 2.5d0*adzi(i,k)*bet(i,k)*wthv_sec(i,k) enddo enddo @@ -976,7 +976,7 @@ subroutine check_eddy() ! be not larger that that. ! if (sqrt(dx*dy) .le. 1000.) smixt(i,k)=min(sqrt(dx*dy),smixt(i,k)) - if (qcl(i,kb) == 0 .and. qcl(i,k) > 0 .and. brunt(i,k) > 1.0d-4) then + if (qcl(i,kb) == zero .and. qcl(i,k) > zero .and. brunt(i,k) > 1.0d-4) then !If just above the cloud top and atmosphere is stable, set to 0.1 of local dz smixt(i,k) = wrk endif @@ -1096,7 +1096,7 @@ subroutine canuto() omega0 = a4 / (one-a5*buoy_sgs2) omega1 = omega0 / (c+c) - omega2 = omega1*f3+(5./4.)*omega0*f4 + omega2 = omega1*f3+(5.0d0/4.0d0)*omega0*f4 ! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) @@ -1119,7 +1119,7 @@ subroutine canuto() !aab ! Implemetation of the C01 approach in this subroutine is nearly complete @@ -1256,14 +1256,14 @@ subroutine assumed_pdf() Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi ! Proportionality coefficients between widths of each vertical velocity ! gaussian and the sqrt of the second moment of w - w2_1 = 0.4 - w2_2 = 0.4 + w2_1 = 0.4d0 + w2_2 = 0.4d0 ! Compute realtive weight of the first PDF "plume" ! See Eq A4 in Pete's dissertaion - Ensure 0.01 < a < 0.99 wrk = one - w2_1 - aterm = max(atmin,min(half*(one-Skew_w*sqrt(one/(4.*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) + aterm = max(atmin,min(half*(one-Skew_w*sqrt(one/(4.0d0*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) onema = one - aterm sqrtw2t = sqrt(wrk) @@ -1347,12 +1347,12 @@ subroutine assumed_pdf() ! Skew_qw = skew_facw*Skew_w - IF (tsign > 0.4) THEN + IF (tsign > 0.4d0) THEN Skew_qw = skew_facw*Skew_w - ELSEIF (tsign <= 0.2) THEN + ELSEIF (tsign <= 0.2d0) THEN Skew_qw = zero ELSE - Skew_qw = (skew_facw/0.2) * Skew_w * (tsign-0.2) + Skew_qw = (skew_facw/0.2d0) * Skew_w * (tsign-0.2d0) ENDIF wrk1 = qw1_1 * qw1_1 @@ -1386,7 +1386,7 @@ subroutine assumed_pdf() testvar = aterm*sqrtqw2_1*sqrtthl2_1 + onema*sqrtqw2_2*sqrtthl2_2 - IF (testvar == 0) THEN + IF (testvar == zero) THEN r_qwthl_1 = zero ELSE r_qwthl_1 = max(-one,min(one,(qwthlsec-aterm*(qw1_1-qw_first)*(thl1_1-thl_first) & @@ -1560,7 +1560,7 @@ subroutine assumed_pdf() diag_qn = min(max(zero, aterm*qn1 + onema*qn2), total_water(i,k)) diag_ql = min(max(zero, aterm*ql1 + onema*ql2), diag_qn) - diag_qi = diag_qn - diag_ql + diag_qi = max(zero, diag_qn - diag_ql) ! Update temperature variable based on diagnosed cloud properties @@ -1579,11 +1579,6 @@ subroutine assumed_pdf() ! Update ncpl and ncpi Anning Cheng 03/11/2016 ! ncpl(i,k) = diag_ql/max(qc(i,k),1.e-10)*ncpl(i,k) - qc(i,k) = diag_ql - qi(i,k) = diag_qi - qwv(i,k) = total_water(i,k) - diag_qn - cld_sgs(i,k) = diag_frac - ! Update ncpl and ncpi Moorthi 12/12/2018 if (imp_phys > 0) then if (ncpl(i,k) > nmin) then @@ -1598,6 +1593,10 @@ subroutine assumed_pdf() endif endif + qc(i,k) = diag_ql + qi(i,k) = diag_qi + qwv(i,k) = max(zero, total_water(i,k) - diag_qn) + cld_sgs(i,k) = diag_frac ! Compute the liquid water flux wqls = aterm * ((w1_1-w_first)*ql1) + onema * ((w1_2-w_first)*ql2) diff --git a/gfsphysics/physics/get_prs.f b/gfsphysics/physics/get_prs.f index 5994d0e63..9ce05c904 100644 --- a/gfsphysics/physics/get_prs.f +++ b/gfsphysics/physics/get_prs.f @@ -22,8 +22,10 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, &, q(ix,levs,ntrac) real(kind=kind_phys) xcp(ix,levs), xr(ix,levs), kappa(ix,levs) real(kind=kind_phys) tem, dphib, dphit, dphi - real (kind=kind_phys), parameter :: zero=0.0, p00i=1.0e-5 - &, rkapi=1.0/rkap, rkapp1=1.0+rkap + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 + &, half=0.5d0, p00i=1.0d-5 + &, rkapi=one/rkap + &, rkapp1=one+rkap integer i, k, n ! do k=1,levs @@ -33,7 +35,7 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, enddo ! if( gen_coord_hybrid ) then ! hmhj - if( thermodyn_id.eq.3 ) then ! Enthalpy case + if( thermodyn_id == 3 ) then ! Enthalpy case ! ! hmhj : This is for generalized hybrid (Henry) with finite difference ! in the vertical and enthalpy as the prognostic (thermodynamic) @@ -47,13 +49,13 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, do k=1,levs do i=1,im kappa(i,k) = xr(i,k)/xcp(i,k) - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half prkl(i,k) = (prsl(i,k)*p00i) ** kappa(i,k) enddo enddo do k=2,levs do i=1,im - tem = 0.5 * (kappa(i,k) + kappa(i,k-1)) + tem = half * (kappa(i,k) + kappa(i,k-1)) prki(i,k-1) = (prsi(i,k)*p00i) ** tem enddo enddo @@ -61,14 +63,14 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, prki(i,1) = (prsi(i,1)*p00i) ** kappa(i,1) enddo k = levs + 1 - if (prsi(1,k) .gt. 0.0) then + if (prsi(1,k) > zero) then do i=1,im prki(i,k) = (prsi(i,k)*p00i) ** kappa(i,levs) enddo endif ! do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + phii(i,1) = zero ! Ignoring topography height here enddo DO k=1,levs do i=1,im @@ -82,16 +84,16 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, ENDDO ENDDO endif - if (prsl(1,1) <= 0.0) then + if (prsl(1,1) <= zero) then do k=1,levs do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half enddo enddo endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + phii(i,1) = zero ! Ignoring topography height here enddo call GET_R(im,ix,levs,ntrac,q,xr) DO k=1,levs @@ -110,44 +112,44 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, if (prki(1,1) <= zero .or. prkl(1,1) <= zero) then do k=1,levs do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half prkl(i,k) = (prsl(i,k)*p00i) ** rkap - enddo - enddo - do k=1,levs+1 - do i=1,im - prki(i,k) = (prsi(i,k)*p00i) ** rkap - enddo enddo + enddo + do k=1,levs+1 do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + prki(i,k) = (prsi(i,k)*p00i) ** rkap enddo - DO k=1,levs - do i=1,im - TEM = rd * T(i,k)*(1.0+NU*max(Q(i,k,1),zero)) - DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM - & / (PRSI(i,k) + PRSI(i,k+1)) - phil(i,k) = phii(i,k) + DPHI - phii(i,k+1) = phil(i,k) + DPHI + enddo + do i=1,im + phii(i,1) = zero ! Ignoring topography height here + enddo + DO k=1,levs + do i=1,im + TEM = rd * T(i,k) * (one+NU*max(Q(i,k,1),zero)) + DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM + & / (PRSI(i,k) + PRSI(i,k+1)) + phil(i,k) = phii(i,k) + DPHI + phii(i,k+1) = phil(i,k) + DPHI ! if (k == 1 .and. phil(i,k) < 0.0) write(0,*)' phil=',phil(i,k) ! &,' dphi=',dphi,' prsi=',prsi(i,k),prsi(i,k+1),' tem=',tem - ENDDO ENDDO + ENDDO endif - if (prsl(1,1) <= 0.0) then + if (prsl(1,1) <= zero) then do k=1,levs do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half enddo enddo endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + phii(i,1) = zero ! Ignoring topography height here enddo DO k=1,levs do i=1,im - TEM = rd * T(i,k)*(1.0+NU*max(Q(i,k,1),zero)) + TEM = rd * T(i,k)*(one+NU*max(Q(i,k,1),zero)) DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM & / (PRSI(i,k) + PRSI(i,k+1)) phil(i,k) = phii(i,k) + DPHI @@ -183,20 +185,20 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, enddo enddo endif - if (prsl(1,1) <= 0.0) then + if (prsl(1,1) <= zero) then do k=1,levs do i=1,im - PRSL(i,k) = 100.0 * PRKL(i,k) ** rkapi + PRSL(i,k) = 100.0d0 * PRKL(i,k) ** rkapi enddo enddo endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + phii(i,1) = zero ! Ignoring topography height here enddo DO k=1,levs do i=1,im - TEM = CP * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + TEM = CP * T(i,k) * (one + NU*max(Q(i,k,1),zero)) & / PRKL(i,k) DPHIB = (PRKI(i,k) - PRKL(i,k)) * TEM DPHIT = (PRKL(i,k ) - PRKI(i,k+1)) * TEM @@ -232,14 +234,14 @@ subroutine GET_PHI(im,ix,levs,ntrac,t,q, &, T(ix,levs), q(ix,levs,ntrac) real(kind=kind_phys) xr(ix,levs) real(kind=kind_phys) tem, dphib, dphit, dphi - real (kind=kind_phys), parameter :: zero=0.0 + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 integer i, k, n ! do i=1,im phii(i,1) = zero ! Ignoring topography height here enddo if( gen_coord_hybrid ) then ! hmhj - if( thermodyn_id.eq.3 ) then ! Enthalpy case + if( thermodyn_id == 3 ) then ! Enthalpy case call GET_R(im,ix,levs,ntrac,q,xr) DO k=1,levs do i=1,im @@ -256,7 +258,7 @@ subroutine GET_PHI(im,ix,levs,ntrac,t,q, else ! gc Virtual Temp DO k=1,levs do i=1,im - TEM = RD * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + TEM = RD * T(i,k) * (one + NU*max(Q(i,k,1),zero)) DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM & /(PRSI(i,k) + PRSI(i,k+1)) phil(i,k) = phii(i,k) + DPHI @@ -267,7 +269,7 @@ subroutine GET_PHI(im,ix,levs,ntrac,t,q, else ! Not gc Virt Temp (Orig Joe) DO k=1,levs do i=1,im - TEM = CP * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + TEM = CP * T(i,k) * (one + NU*max(Q(i,k,1),zero)) & / PRKL(i,k) DPHIB = (PRKI(i,k) - PRKL(i,k)) * TEM DPHIT = (PRKL(i,k ) - PRKI(i,k+1)) * TEM @@ -285,7 +287,7 @@ subroutine GET_CPR(im,ix,levs,ntrac,q,xcp,xr) USE tracer_const implicit none ! - real (kind=kind_phys), parameter :: zero=0.0 + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 integer im, ix, levs, ntrac real(kind=kind_phys) q(ix,levs,ntrac) real(kind=kind_phys) xcp(ix,levs),xr(ix,levs),sumq(ix,levs) @@ -307,8 +309,8 @@ subroutine GET_CPR(im,ix,levs,ntrac,q,xcp,xr) enddo do k=1,levs do i=1,im - xr(i,k) = (1.-sumq(i,k))*ri(0) + xr(i,k) - xcp(i,k) = (1.-sumq(i,k))*cpi(0) + xcp(i,k) + xr(i,k) = (one-sumq(i,k))*ri(0) + xr(i,k) + xcp(i,k) = (one-sumq(i,k))*cpi(0) + xcp(i,k) enddo enddo ! @@ -320,7 +322,7 @@ subroutine GET_R(im,ix,levs,ntrac,q,xr) USE tracer_const implicit none ! - real (kind=kind_phys), parameter :: zero=0.0 + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 integer im, ix, levs, ntrac real(kind=kind_phys) q(ix,levs,ntrac) real(kind=kind_phys) xr(ix,levs),sumq(ix,levs) @@ -329,7 +331,7 @@ subroutine GET_R(im,ix,levs,ntrac,q,xr) sumq = zero xr = zero do n=1,ntrac - if( ri(n) > 0.0 ) then + if( ri(n) > zero ) then do k=1,levs do i=1,im xr(i,k) = xr(i,k) + q(i,k,n) * ri(n) @@ -340,7 +342,7 @@ subroutine GET_R(im,ix,levs,ntrac,q,xr) enddo do k=1,levs do i=1,im - xr(i,k) = (1.-sumq(i,k))*ri(0) + xr(i,k) + xr(i,k) = (one-sumq(i,k))*ri(0) + xr(i,k) enddo enddo ! @@ -352,7 +354,7 @@ subroutine GET_CP(im,ix,levs,ntrac,q,xcp) USE tracer_const implicit none ! - real (kind=kind_phys), parameter :: zero=0.0 + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 integer im, ix, levs, ntrac real(kind=kind_phys) q(ix,levs,ntrac) real(kind=kind_phys) xcp(ix,levs),sumq(ix,levs) @@ -361,7 +363,7 @@ subroutine GET_CP(im,ix,levs,ntrac,q,xcp) sumq = zero xcp = zero do n=1,ntrac - if( cpi(n) > 0.0 ) then + if( cpi(n) > zero ) then do k=1,levs do i=1,im xcp(i,k) = xcp(i,k) + q(i,k,n) * cpi(n) @@ -372,7 +374,7 @@ subroutine GET_CP(im,ix,levs,ntrac,q,xcp) enddo do k=1,levs do i=1,im - xcp(i,k) = (1.-sumq(i,k))*cpi(0) + xcp(i,k) + xcp(i,k) = (one-sumq(i,k))*cpi(0) + xcp(i,k) enddo enddo ! diff --git a/gfsphysics/physics/m_micro_driver.F90 b/gfsphysics/physics/m_micro_driver.F90 index 26a04d96a..07979a810 100644 --- a/gfsphysics/physics/m_micro_driver.F90 +++ b/gfsphysics/physics/m_micro_driver.F90 @@ -52,11 +52,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & !------------------------------------ ! input ! real, parameter :: r_air = 3.47d-3 - real, parameter :: one=1.0, oneb3=one/3.0, onebcp=one/cp, & + real, parameter :: one=1.0d0, oneb3=one/3.0d0, onebcp=one/cp, & + zero=0.0d0, half=0.5d0, onebg=one/grav, & & kapa=rgas*onebcp, cpbg=cp/grav, & & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp,& - & qsmall=1.e-14, rainmin = 1.0e-13, & - & fourb3=4.0/3.0, RL_cub=1.0e-15, nmin=1.0 + & qsmall=1.0d-14, rainmin = 1.0d-13, & + & fourb3=4.0d0/3.0d0, RL_cub=1.0d-15, nmin=1.0d0 integer, parameter :: ncolmicro = 1 integer,intent(in) :: im, ix,lm, ipr, kdt, fprcp, pdfflag @@ -217,27 +218,28 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! real (kind=kind_phys), parameter :: disp_liu=2., ui_scale=1.0 & ! &, dcrit=20.0e-6 & - real (kind=kind_phys), parameter :: disp_liu=1.0, ui_scale=1.0 & - &, dcrit=1.0e-6 & + real (kind=kind_phys), parameter :: disp_liu=1.0d0 & + &, ui_scale=1.0d0 & + &, dcrit=1.0d-6 & ! &, ts_autice=1800.0 & ! &, ts_autice=3600.0 & !time scale - &, ninstr8 = 0.1e6 & - &, ncnstr8 = 100.0e6 + &, ninstr8 = 0.1d6 & + &, ncnstr8 = 100.0d6 real(kind=kind_phys):: k_gw, maxkh, tausurf_gw, overscale, tx1, rh1_r8 real(kind=kind_phys):: t_ice_denom - integer, dimension(1) :: lev_sed_strt ! sedimentation start level - real(kind=kind_phys), parameter :: sig_sed_strt=0.05 ! normalized pressure at sedimentation start + integer, dimension(1) :: lev_sed_strt ! sedimentation start level + real(kind=kind_phys), parameter :: sig_sed_strt=0.05d0 ! normalized pressure at sedimentation start real(kind=kind_phys),dimension(3) :: ccn_diag real(kind=kind_phys),dimension(58) :: cloudparams integer, parameter :: CCN_PARAM=2, IN_PARAM=5 - real(kind=kind_phys), parameter ::fdust_drop=1.0, fsoot_drop=0.1 & - &, sigma_nuc_r8=0.28,SCLMFDFR=0.03 -! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1 + real(kind=kind_phys), parameter ::fdust_drop=1.0d0, fsoot_drop=0.1d0 & + &, sigma_nuc_r8=0.28d0,SCLMFDFR=0.03d0 +! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1d0 type (AerProps), dimension (IM,LM) :: AeroProps type (AerProps) :: AeroAux, AeroAux_b @@ -294,9 +296,9 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CNV_UPDF(i,k) = cf_upi(i,ll) CNV_DQLDT(I,K) = CNV_DQLDT_i(I,ll) CLCN(I,k) = CLCN_i(I,ll) - CLLS(I,k) = max(CLLS_io(I,ll)-CLCN_i(I,ll),0.0) - PLO(i,k) = prsl_i(i,ll)*0.01 - zlo(i,k) = phil(i,ll) * (1.0/grav) + CLLS(I,k) = max(CLLS_io(I,ll)-CLCN_i(I,ll),zero) + PLO(i,k) = prsl_i(i,ll)*0.01d0 + zlo(i,k) = phil(i,ll) * onebg temp(i,k) = t_io(i,ll) radheat(i,k) = lwheat_i(i,ll) + swheat_i(i,ll) rhc(i,k) = rhc_i(i,ll) @@ -310,8 +312,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & DO K=0, LM ll = lm-k DO I = 1,IM - PLE(i,k) = prsi_i(i,ll) *.01 ! interface pressure in hPa - zet(i,k+1) = phii(i,ll) * (1.0/grav) + PLE(i,k) = prsi_i(i,ll) *0.01d0 ! interface pressure in hPa + zet(i,k+1) = phii(i,ll) * onebg END DO END DO if (.not. skip_macro) then @@ -339,7 +341,6 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & omega(i,k) = omega_i(i,k) ncpl(i,k) = ncpl_io(i,k) ncpi(i,k) = ncpi_io(i,k) - ncpi(i,k) = ncpi_io(i,k) rnw(i,k) = rnw_io(i,k) snw(i,k) = snw_io(i,k) qgl(i,k) = qgl_io(i,k) @@ -355,9 +356,9 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CNV_UPDF(i,k) = cf_upi(i,k) CNV_DQLDT(I,K) = CNV_DQLDT_i(I,k) CLCN(I,k) = CLCN_i(I,k) - CLLS(I,k) = max(CLLS_io(I,k)-CLCN_i(I,k),0.0) - PLO(i,k) = prsl_i(i,k)*0.01 - zlo(i,k) = phil(i,k) * (1.0/grav) + CLLS(I,k) = max(CLLS_io(I,k)-CLCN_i(I,k),zero) + PLO(i,k) = prsl_i(i,k)*0.01d0 + zlo(i,k) = phil(i,k) * onebg temp(i,k) = t_io(i,k) radheat(i,k) = lwheat_i(i,k) + swheat_i(i,k) rhc(i,k) = rhc_i(i,k) @@ -370,8 +371,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & END DO DO K=0, LM DO I = 1,IM - PLE(i,k) = prsi_i(i,k) *.01 ! interface pressure in hPa - zet(i,k+1) = phii(i,k) * (1.0/grav) + PLE(i,k) = prsi_i(i,k) * 0.01d0 ! interface pressure in hPa + zet(i,k+1) = phii(i,k) * onebg END DO END DO if (.not. skip_macro) then @@ -408,19 +409,19 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & QICN(I,K), CLCN(I,K), NCPL(I,K), & & NCPI(I,K), qc_min) if (rnw(i,k) <= qc_min(1)) then - ncpr(i,k) = 0.0 + ncpr(i,k) = zero elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0), nmin) + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0d0), nmin) endif if (snw(i,k) <= qc_min(2)) then - ncps(i,k) = 0.0 + ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) endif if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = 0.0 + ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) endif enddo @@ -433,8 +434,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & DO I=1, IM DO K = LM-2, 10, -1 - If ((CNV_DQLDT(I,K) <= 1.0e-9) .and. & - & (CNV_DQLDT(I,K+1) > 1.0e-9)) then + If ((CNV_DQLDT(I,K) <= 1.0d-9) .and. & + & (CNV_DQLDT(I,K+1) > 1.0d-9)) then KCT(I) = K+1 exit end if @@ -514,8 +515,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do l=lm-1,1,-1 do i=1,im - tx1 = 0.5 * (temp(i,l+1) + temp(i,l)) - kh(i,l) = 3.55e-7*tx1**2.5*(rgas*0.01) / ple(i,l) !kh molecule diff only needing refinement + tx1 = half * (temp(i,l+1) + temp(i,l)) + kh(i,l) = 3.55d-7*tx1**2.5d0*(rgas*0.01d0) / ple(i,l) !kh molecule diff only needing refinement enddo end do do i=1,im @@ -524,38 +525,38 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & enddo do L=LM,1,-1 do i=1,im - blk_l(i,l) = 1.0 / ( 1.0/max(0.15*ZPBL(i),0.4*zlo(i,lm-1))& - & + 1.0/(zlo(i,l)*.4) ) + blk_l(i,l) = one / (one/max(0.15d0*ZPBL(i),0.4d0*zlo(i,lm-1))& + & + one/(zlo(i,l)*.4d0) ) - SC_ICE(i,l) = 1.0 - NCPL(i,l) = MAX( NCPL(i,l), 0.) - NCPI(i,l) = MAX( NCPI(i,l), 0.) - RAD_CF(i,l) = max(0.0, min(CLLS(i,l)+CLCN(i,l), 1.0)) + SC_ICE(i,l) = one + NCPL(i,l) = MAX( NCPL(i,l), 0.0d0) + NCPI(i,l) = MAX( NCPI(i,l), 0.0d0) + RAD_CF(i,l) = max(zero, min(CLLS(i,l)+CLCN(i,l), one)) if (.not. iccn) then - CDNC_NUC(i,l) = 0.0 - INC_NUC(i,l) = 0.0 + CDNC_NUC(i,l) = zero + INC_NUC(i,l) = zero endif enddo end do ! T_ICE_ALL = TICE - 40.0 T_ICE_ALL = CLOUDPARAMS(33) + TICE - t_ice_denom = 1.0 / (tice - t_ice_all) + t_ice_denom = one / (tice - t_ice_all) do l=1,lm - rhdfdar8(l) = 1.e-8 - rhu00r8(l) = 0.95 + rhdfdar8(l) = 1.d-8 + rhu00r8(l) = 0.95d0 - ttendr8(l) = 0. - qtendr8(l) = 0. - cwtendr8(l) = 0. + ttendr8(l) = zero + qtendr8(l) = zero + cwtendr8(l) = zero - npccninr8(l) = 0. + npccninr8(l) = zero enddo do k=1,10 do l=1,lm - rndstr8(l,k) = 2.0e-7 + rndstr8(l,k) = 2.0d-7 enddo enddo @@ -589,14 +590,14 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & if ( aero_in ) then AERMASSMIX(:,:,1:ntrcaer) = aerfld_i(:,:,1:ntrcaer) else - AERMASSMIX(:,:,1:5) = 1.e-6 - AERMASSMIX(:,:,6:15) = 2.e-14 + AERMASSMIX(:,:,1:5) = 1.0d-6 + AERMASSMIX(:,:,6:15) = 2.0d-14 end if call AerConversion1 (AERMASSMIX, AeroProps) deallocate(AERMASSMIX) use_average_v = .false. - if (USE_AV_V > 0.0) then + if (USE_AV_V > zero) then use_average_v = .true. end if @@ -607,58 +608,58 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & kcldtopcvn = KCT(I) - tausurf_gw = min(0.5*SQRT(TAUOROX(I)*TAUOROX(I) & - & + TAUOROY(I)*TAUOROY(I)), 10.0) + tausurf_gw = min(half*SQRT(TAUOROX(I)*TAUOROX(I) & + & + TAUOROY(I)*TAUOROY(I)), 10.0d0) do k=1,lm - uwind_gw(k) = min(0.5*SQRT( U1(I,k)*U1(I,k) & - & + V1(I,k)*V1(I,k)), 50.0) + uwind_gw(k) = min(half*SQRT( U1(I,k)*U1(I,k) & + & + V1(I,k)*V1(I,k)), 50.0d0) ! tausurf_gw =tausurf_gw + max (tausurf_gw, min(0.5*SQRT(TAUX(I , J)**2+TAUY(I , J)**2), 10.0)*BKGTAU) !adds a minimum value from unresolved sources - pm_gw(k) = 100.0*PLO(I,k) + pm_gw(k) = 100.0d0*PLO(I,k) tm_gw(k) = TEMP(I,k) - nm_gw(k) = 0.0 + nm_gw(k) = zero rho_gw(k) = pm_gw(k) /(RGAS*tm_gw(k)) ter8(k) = TEMP(I,k) - plevr8(k) = 100.*PLO(I,k) + plevr8(k) = 100.0d0*PLO(I,k) ndropr8(k) = NCPL(I,k) qir8(k) = QILS(I,k) + QICN(I,k) qcr8(k) = QLLS(I,k) + QLCN(I,k) qcaux(k) = qcr8(k) - npccninr8(k) = 0.0 - naair8(k) = 0.0 + npccninr8(k) = zero + naair8(k) = zero - npre8(k) = 0.0 + npre8(k) = zero - if (RAD_CF(I,k) > 0.01 .and. qir8(k) > 0.0) then + if (RAD_CF(I,k) > 0.01d0 .and. qir8(k) > zero) then npre8(k) = NPRE_FRAC*NCPI(I,k) else - npre8(k) = 0.0 + npre8(k) = zero endif omegr8(k) = OMEGA(I,k) - lc_turb(k) = max(blk_l(I,k), 50.0) + lc_turb(k) = max(blk_l(I,k), 50.0d0) ! rad_cooling(k) = RADheat(I,k) - if (npre8(k) > 0.0 .and. qir8(k) > 0.0) then - dpre8(k) = ( qir8(k)/(6.0*npre8(k)*900.0*PI))**(1.0/3.0) + if (npre8(k) > zero .and. qir8(k) > zero) then + dpre8(k) = ( qir8(k)/(6.0*npre8(k)*900.0d0*PI))**(one/3.0d0) else - dpre8(k) = 1.0e-9 + dpre8(k) = 1.0d-9 endif wparc_ls(k) = -omegr8(k) / (rho_gw(k)*GRAV) & & + cpbg * radheat(i,k) ! & + cpbg * rad_cooling(k) enddo do k=0,lm - pi_gw(k) = 100.0*PLE(I,k) - rhoi_gw(k) = 0.0 - ni_gw(k) = 0.0 - ti_gw(k) = 0.0 + pi_gw(k) = 100.0d0*PLE(I,k) + rhoi_gw(k) = zero + ni_gw(k) = zero + ti_gw(k) = zero enddo @@ -671,37 +672,37 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & ti_gw, nm_gw, q1(i,:)) do k=1,lm - nm_gw(k) = max(nm_gw(k), 0.005) + nm_gw(k) = max(nm_gw(k), 0.005d0) h_gw(k) = k_gw*rho_gw(k)*uwind_gw(k)*nm_gw(k) - if (h_gw(K) > 0.0) then - h_gw(K) = sqrt(2.0*tausurf_gw/h_gw(K)) + if (h_gw(K) > zero) then + h_gw(K) = sqrt(2.0d0*tausurf_gw/h_gw(K)) end if - wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133 + wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133d0 - wparc_cgw(k) = 0.0 + wparc_cgw(k) = zero end do !!!======== Subgrid variability from Convective Sources According to Barahona et al. 2014 in prep if (kcldtopcvn > 20) then - ksa1 = 1.0 + ksa1 = one Nct = nm_gw(kcldtopcvn) - Wct = max(CNV_CVW(I,kcldtopcvn), 0.0) + Wct = max(CNV_CVW(I,kcldtopcvn), zero) fcn = maxval(CNV_UPDF(I,kcldtopcvn:LM)) do k=1,kcldtopcvn c2_gw = (nm_gw(k) + Nct) / Nct - wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56* & - & 1.806*c2_gw*c2_gw)*Wct*0.133 + wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56d0* & + & 1.806d0*c2_gw*c2_gw)*Wct*0.133d0 enddo end if do k=1,lm - dummyW(k) = 0.133*k_gw*uwind_gw(k)/nm_gw(k) + dummyW(k) = 0.133d0*k_gw*uwind_gw(k)/nm_gw(k) enddo do K=1, LM-5, 1 @@ -711,8 +712,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & end do do l=1,min(k,lm-5) - wparc_cgw(l) = 0.0 - wparc_gw(l) = 0.0 + wparc_cgw(l) = zero + wparc_gw(l) = zero enddo @@ -721,25 +722,25 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & kbmin = min(kbmin, LM-1) - 4 do K = 1, LM wparc_turb(k) = KH(I,k) / lc_turb(k) - dummyW(k) = 10.0 + dummyW(k) = 10.0d0 enddo - if (FRLAND(I) < 0.1 .and. ZPBL(I) < 800.0 .and. & - & TEMP(I,LM) < 298.0 .and. TEMP(I,LM) > 274.0 ) then + if (FRLAND(I) < 0.1d0 .and. ZPBL(I) < 800.0d0 .and. & + & TEMP(I,LM) < 298.0d0 .and. TEMP(I,LM) > 274.0d0 ) then do K = 1, LM - dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01,10.0),-10.0) - dummyW(k) = 1.0 / (1.0+exp(dummyW(k))) + dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01d0,10.0d0),-10.0d0) + dummyW(k) = one / (one+exp(dummyW(k))) enddo maxkh = max(maxval(KH(I,kbmin:LM-1)*nm_gw(kbmin:LM-1)/ & - & 0.17), 0.3) + & 0.17d0), 0.3d0) do K = 1, LM - wparc_turb(k) = (1.0-dummyW(k))*wparc_turb(k) & - & + dummyW(k)*maxkh + wparc_turb(k) = (one-dummyW(k))*wparc_turb(k) & + & + dummyW(k)*maxkh enddo end if - wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2) + wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2d0) @@ -757,11 +758,11 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do K = 1, LM - if (plevr8(K) > 70.0) then + if (plevr8(K) > 70.0d0) then - ccn_diag(1) = 0.001 - ccn_diag(2) = 0.004 - ccn_diag(3) = 0.01 + ccn_diag(1) = 0.001d0 + ccn_diag(2) = 0.004d0 + ccn_diag(3) = 0.01d0 if (K > 2 .and. K <= LM-2) then tauxr8 = (ter8(K-1) + ter8(K+1) + ter8(K)) * oneb3 @@ -776,8 +777,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! call init_Aer(AeroAux_b) ! endif - pfrz_inc_r8(k) = 0.0 - rh1_r8 = 0.0 !related to cnv_dql_dt, needed to changed soon + pfrz_inc_r8(k) = zero + rh1_r8 = zero !related to cnv_dql_dt, needed to changed soon ! if (lprnt) write(0,*)' bef aero npccninr8=',npccninr8(k),' k=',k & ! &,' ccn_param=',ccn_param,' in_param=',in_param & @@ -797,7 +798,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! & size(ccn_diag), lprnt) ! if (lprnt) write(0,*)' aft aero npccninr8=',npccninr8(k),' k=',k - if (npccninr8(k) < 1.0e-12) npccninr8(k) = 0.0 + if (npccninr8(k) < 1.0d-12) npccninr8(k) = zero ! CCN01(I,K) = max(ccn_diag(1)*1e-6, 0.0) ! CCN04(I,K) = max(ccn_diag(2)*1e-6, 0.0) @@ -806,31 +807,31 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & else - ccn_diag(:) = 0.0 - smaxliq(K) = 0.0 - swparc(K) = 0.0 - smaxicer8(K) = 0.0 - nheticer8(K) = 0.0 - sc_icer8(K) = 2.0 + ccn_diag(:) = zero + smaxliq(K) = zero + swparc(K) = zero + smaxicer8(K) = zero + nheticer8(K) = zero + sc_icer8(K) = 2.0d0 ! sc_icer8(K) = 1.0 - naair8(K) = 0.0 - npccninr8(K) = 0.0 - nlimicer8(K) = 0.0 - nhet_immr8(K) = 0.0 - dnhet_immr8(K) = 0.0 - nhet_depr8(K) = 0.0 - nhet_dhfr8(K) = 0.0 - dust_immr8(K) = 0.0 - dust_depr8(K) = 0.0 - dust_dhfr8(K) = 0.0 + naair8(K) = zero + npccninr8(K) = zero + nlimicer8(K) = zero + nhet_immr8(K) = zero + dnhet_immr8(K) = zero + nhet_depr8(K) = zero + nhet_dhfr8(K) = zero + dust_immr8(K) = zero + dust_depr8(K) = zero + dust_dhfr8(K) = zero end if ! SMAXL(I,k) = smaxliq(k) * 100.0 ! SMAXI(I,k) = smaxicer8(k) * 100.0 - NHET_NUC(I,k) = nheticer8(k) * 1e-6 - NLIM_NUC(I,k) = nlimicer8(k) * 1e-6 - SC_ICE(I,k) = min(max(sc_icer8(k),1.0),2.0) + NHET_NUC(I,k) = nheticer8(k) * 1.0d-6 + NLIM_NUC(I,k) = nlimicer8(k) * 1.0d-6 + SC_ICE(I,k) = min(max(sc_icer8(k),one),2.0d0) ! SC_ICE(I,k) = min(max(sc_icer8(k),1.0),1.2) ! if(temp(i,k) < T_ICE_ALL) SC_ICE(i,k) = max(SC_ICE(I,k), 1.2) ! if(temp(i,k) < T_ICE_ALL) SC_ICE(i,k) = max(SC_ICE(I,k), 1.5) @@ -853,14 +854,14 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CDNC_NUC(I,k) = npccninr8(k) INC_NUC (I,k) = naair8(k) endif - NHET_IMM(I,k) = max(nhet_immr8(k), 0.0) - DNHET_IMM(I,k) = max(dnhet_immr8(k), 0.0) - NHET_DEP(I,k) = nhet_depr8(k) * 1e-6 - NHET_DHF(I,k) = nhet_dhfr8(k) * 1e-6 - DUST_IMM(I,k) = max(dust_immr8(k), 0.0)*1e-6 - DUST_DEP(I,k) = max(dust_depr8(k), 0.0)*1e-6 - DUST_DHF(I,k) = max(dust_dhfr8(k), 0.0)*1e-6 - WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8 + NHET_IMM(I,k) = max(nhet_immr8(k), zero) + DNHET_IMM(I,k) = max(dnhet_immr8(k), zero) + NHET_DEP(I,k) = nhet_depr8(k) * 1.0d-6 + NHET_DHF(I,k) = nhet_dhfr8(k) * 1.0d-6 + DUST_IMM(I,k) = max(dust_immr8(k), zero)*1.0d-6 + DUST_DEP(I,k) = max(dust_depr8(k), zero)*1.0d-6 + DUST_DHF(I,k) = max(dust_dhfr8(k), zero)*1.0d-6 + WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8d0 SIGW_GW (I,k) = wparc_gw(k) * wparc_gw(k) SIGW_CNV (I,k) = wparc_cgw(k) * wparc_cgw(k) SIGW_TURB (I,k) = wparc_turb(k) * wparc_turb(k) @@ -973,24 +974,24 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do k=1,lm do i=1,im - if (CNV_MFD(i,k) > 1.0e-6) then - tx1 = 1.0 / CNV_MFD(i,k) + if (CNV_MFD(i,k) > 1.0d-6) then + tx1 = one / CNV_MFD(i,k) CNV_NDROP(i,k) = CNV_NDROP(i,k) * tx1 CNV_NICE(i,k) = CNV_NICE(i,k) * tx1 else - CNV_NDROP(i,k) = 0.0 - CNV_NICE(i,k) = 0.0 + CNV_NDROP(i,k) = zero + CNV_NICE(i,k) = zero endif ! temp(i,k) = th1(i,k) * PK(i,k) - RAD_CF(i,k) = min(CLLS(i,k)+CLCN(i,k), 1.0) + RAD_CF(i,k) = min(CLLS(i,k)+CLCN(i,k), one) ! if (.not. iccn) then - if (PFRZ(i,k) > 0.0) then + if (PFRZ(i,k) > zero) then INC_NUC(i,k) = INC_NUC(i,k) * PFRZ(i,k) NHET_NUC(i,k) = NHET_NUC(i,k) * PFRZ(i,k) else - INC_NUC(i,k) = 0.0 - NHET_NUC(i,k) = 0.0 + INC_NUC(i,k) = zero + NHET_NUC(i,k) = zero endif endif @@ -1046,21 +1047,21 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & QL_TOT(i,k) = QLCN(i,k) + QLLS(i,k) QI_TOT(i,k) = QICN(i,k) + QILS(i,k) ! Anning if negative, borrow water and ice from vapor 11/23/2016 - if (QL_TOT(i,k) < 0.0) then + if (QL_TOT(i,k) < zero) then Q1(i,k) = Q1(i,k) + QL_TOT(i,k) TEMP(i,k) = TEMP(i,k) - lvbcp*QL_TOT(i,k) - QL_TOT(i,k) = 0.0 + QL_TOT(i,k) = zero endif - if (QI_TOT(i,k) < 0.0) then + if (QI_TOT(i,k) < zero) then Q1(i,k) = Q1(i,k) + QI_TOT(i,k) TEMP(i,k) = TEMP(i,k) - lsbcp*QI_TOT(i,k) - QI_TOT(i,k) = 0.0 + QI_TOT(i,k) = zero endif QTOT = QL_TOT(i,k) + QI_TOT(i,k) - if (QTOT > 0.0) then - FQA(i,k) = min(max(QCNTOT / QTOT, 0.0), 1.0) + if (QTOT > zero) then + FQA(i,k) = min(max(QCNTOT / QTOT, zero), one) else - FQA(i,k) = 0.0 + FQA(i,k) = zero endif enddo enddo @@ -1071,35 +1072,35 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & !============================================================================================= do I=1,IM - LS_SNR(i) = 0.0 - LS_PRC2(i) = 0.0 + LS_SNR(i) = zero + LS_PRC2(i) = zero nbincontactdust = 1 do l=1,10 do k=1,lm - naconr8(k,l) = 0.0 - rndstr8(k,l) = 2.0e-7 + naconr8(k,l) = zero + rndstr8(k,l) = 2.0d-7 enddo enddo do k=1,lm - npccninr8(k) = 0.0 - naair8(k) = 0.0 - omegr8(k) = 0.0 + npccninr8(k) = zero + naair8(k) = zero + omegr8(k) = zero ! tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) - tx1 = MIN(CLLS(I,k) + CLCN(I,k), 1.00) - if (tx1 > 0.0) then - cldfr8(k) = min(max(tx1, 0.00001), 1.0) + tx1 = MIN(CLLS(I,k) + CLCN(I,k), one) + if (tx1 > zero) then + cldfr8(k) = min(max(tx1, 0.00001d0), one) else - cldfr8(k) = 0.0 + cldfr8(k) = zero endif if (temp(i,k) > tice) then liqcldfr8(k) = cldfr8(k) - icecldfr8(k) = 0.0 + icecldfr8(k) = zero elseif (temp(i,k) <= t_ice_all) then - liqcldfr8(k) = 0.0 + liqcldfr8(k) = zero icecldfr8(k) = cldfr8(k) else icecldfr8(k) = cldfr8(k) * (tice - temp(i,k))/(tice-t_ice_all) @@ -1113,23 +1114,23 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & qcr8(k) = QL_TOT(I,k) qir8(k) = QI_TOT(I,k) - ncr8(k) = MAX(NCPL(I,k), 0.0) - nir8(k) = MAX(NCPI(I,k), 0.0) + ncr8(k) = MAX(NCPL(I,k), zero) + nir8(k) = MAX(NCPI(I,k), zero) qrr8(k) = rnw(I,k) qsr8(k) = snw(I,k) qgr8(k) = qgl(I,k) - nrr8(k) = MAX(NCPR(I,k), 0.0) - nsr8(k) = MAX(NCPS(I,k), 0.0) - ngr8(k) = MAX(ncgl(I,k), 0.0) + nrr8(k) = MAX(NCPR(I,k), zero) + nsr8(k) = MAX(NCPS(I,k), zero) + ngr8(k) = MAX(ncgl(I,k), zero) naair8(k) = INC_NUC(I,k) npccninr8(k) = CDNC_NUC(I,k) - if (cldfr8(k) >= 0.001) then + if (cldfr8(k) >= 0.001d0) then nimmr8(k) = min(DNHET_IMM(I,k),ncr8(k)/(cldfr8(k)*DT_MOIST)) else - nimmr8(k) = 0.0 + nimmr8(k) = zero endif @@ -1144,7 +1145,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & nbincontactdust = naux endif naconr8(K, 1:naux) = AeroAux_b%num(1:naux) - rndstr8(K, 1:naux) = AeroAux_b%dpg(1:naux) * 0.5 + rndstr8(K, 1:naux) = AeroAux_b%dpg(1:naux) * half ! The following moved inside of if(fprcp <= 0) then loop ! Get black carbon properties for contact ice nucleation @@ -1153,11 +1154,11 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! naux = AeroAux_b%nmods ! rnsootr8 (K) = sum(AeroAux_b%dpg(1:naux))/naux - pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0 - rpdelr8(k) = 1. / pdelr8(k) - plevr8(k) = 100. * PLO(I,k) + pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0d0 + rpdelr8(k) = one / pdelr8(k) + plevr8(k) = 100.0d0 * PLO(I,k) zmr8(k) = ZLO(I,k) - ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.e-10) + ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.0d-10) omegr8(k) = WSUB(I,k) ! alphar8(k) = max(alpht_x(i,k)/maxval(alpht_x(i,:))*8.,0.5) ! alphar8(k) = qcvar2 @@ -1165,12 +1166,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & END DO do k=1,lm+1 - pintr8(k) = PLE(I,k-1) * 100.0 + pintr8(k) = PLE(I,k-1) * 100.0d0 kkvhr8(k) = KH(I,k-1) END DO lev_sed_strt = 0 - tx1 = 1.0 / pintr8(lm+1) + tx1 = one / pintr8(lm+1) do k=1,lm if (plevr8(k)*tx1 < sig_sed_strt) then lev_sed_strt(1) = k @@ -1250,8 +1251,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! if (lprint) write(0,*)' prectr8=',prectr8(1), & ! & ' precir8=',precir8(1) - LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) - LS_SNR(I) = max(1000.*precir8(1), 0.0) + LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0d0*precir8(1), zero) do k=1,lm @@ -1262,17 +1263,17 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! &,' qvlatr8=',qvlatr8(k) TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, 0.0) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, 0.0) + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, zero) rnw(I,k) = qrr8(k) snw(I,k) = qsr8(k) NCPR(I,k) = nrr8(k) NCPS(I,k) = nsr8(k) - CLDREFFL(I,k) = min(max(effcr8(k), 10.), 150.) - CLDREFFI(I,k) = min(max(effir8(k), 20.), 150.) - CLDREFFR(I,k) = max(droutr8(k)*0.5*1.e6, 150.) - CLDREFFS(I,k) = max(0.192*dsoutr8(k)*0.5*1.e6, 250.) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0), 150.0d0) + CLDREFFI(I,k) = min(max(effir8(k), 20.0d0), 150.0d0) + CLDREFFR(I,k) = max(droutr8(k)*0.5*1.0d6, 150.0d0) + CLDREFFS(I,k) = max(0.192d0*dsoutr8(k)*0.5d0*1.0d6, 250.0d0) enddo ! K loop @@ -1354,8 +1355,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, aero_in, & & lev_sed_strt) ! - LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) - LS_SNR(I) = max(1000.*precir8(1), 0.0) + LS_PRC2(I) = max(1000.d0*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.d0*precir8(1), zero) do k=1,lm QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 @@ -1364,15 +1365,15 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & rnw(I,k) = rnw(I,k) + qrtend(k)*dt_r8 snw(I,k) = snw(I,k) + qstend(k)*dt_r8 - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, 0.0) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, 0.0) - NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, 0.0) - NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, 0.0) + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, zero) + NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, zero) + NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, zero) - CLDREFFL(I,k) = min(max(effcr8(k), 10.),150.) - CLDREFFI(I,k) = min(max(effir8(k), 20.),150.) - CLDREFFR(I,k) = max(reff_rain(k),150.) - CLDREFFS(I,k) = max(reff_snow(k),250.) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0),150.0d0) + CLDREFFI(I,k) = min(max(effir8(k), 20.0d0),1500.0d0) + CLDREFFR(I,k) = max(reff_rain(k),150.0d0) + CLDREFFS(I,k) = max(reff_snow(k),250.0d0) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1380,13 +1381,13 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! write(0,*)' aft micro_mg_tend LS_PRC2= ', LS_PRC2(i),' ls_snr=',ls_snr(i) ! endif else - LS_PRC2(I) = 0. - LS_SNR(I) = 0. + LS_PRC2(I) = zero + LS_SNR(I) = zero do k=1,lm - CLDREFFL(I,k) = 10. - CLDREFFI(I,k) = 50. - CLDREFFR(I,k) = 1000. - CLDREFFS(I,k) = 250. + CLDREFFL(I,k) = 10.0d0 + CLDREFFI(I,k) = 50.0d0 + CLDREFFR(I,k) = 1000.0d0 + CLDREFFS(I,k) = 250.0d0 enddo ! K loop endif ! @@ -1490,8 +1491,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, aero_in, & & lev_sed_strt) - LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) - LS_SNR(I) = max(1000.*precir8(1), 0.0) + LS_PRC2(I) = max(1000.d0*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.d0*precir8(1), zero) do k=1,lm QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 @@ -1501,17 +1502,17 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & snw(I,k) = snw(I,k) + qstend(k)*dt_r8 qgl(I,k) = qgl(I,k) + qgtend(k)*dt_r8 - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, 0.0) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, 0.0) - NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, 0.0) - NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, 0.0) - NCGL(I,k) = max(NCGL(I,k) + ngtend(k)*dt_r8, 0.0) - - CLDREFFL(I,k) = min(max(effcr8(k), 10.),150.) - CLDREFFI(I,k) = min(max(effir8(k), 20.),150.) - CLDREFFR(I,k) = max(reff_rain(k),150.) - CLDREFFS(I,k) = max(reff_snow(k),250.) - CLDREFFG(I,k) = max(reff_grau(k),250.) + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, zero) + NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, zero) + NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, zero) + NCGL(I,k) = max(NCGL(I,k) + ngtend(k)*dt_r8, zero) + + CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0),150.0d0) + CLDREFFI(I,k) = min(max(effir8(k), 20.0d0),150.0d0) + CLDREFFR(I,k) = max(reff_rain(k),150.0d0) + CLDREFFS(I,k) = max(reff_snow(k),250.0d0) + CLDREFFG(I,k) = max(reff_grau(k),250.0d0) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1519,14 +1520,14 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! write(0,*)' aft micro_mg_tend LS_PRC2= ', LS_PRC2(i),' ls_snr=',ls_snr(i) ! endif else - LS_PRC2(I) = 0. - LS_SNR(I) = 0. + LS_PRC2(I) = zero + LS_SNR(I) = zero do k=1,lm - CLDREFFL(I,k) = 10. - CLDREFFI(I,k) = 50. - CLDREFFR(I,k) = 1000. - CLDREFFS(I,k) = 250. - CLDREFFG(I,k) = 250. + CLDREFFL(I,k) = 100.0d0 + CLDREFFI(I,k) = 500.0d0 + CLDREFFR(I,k) = 1000.0d0 + CLDREFFS(I,k) = 250.0d0 + CLDREFFG(I,k) = 250.0d0 enddo ! K loop endif endif @@ -1553,19 +1554,19 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & QL_TOT(I,K) = QLLS(I,K) + QLCN(I,K) QI_TOT(I,K) = QILS(I,K) + QICN(I,K) if (rnw(i,k) <= qc_min(1)) then - ncpl(i,k) = 0.0 - elseif (ncpl(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpl(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0), nmin) + ncpr(i,k) = zero + elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0d0), nmin) endif if (snw(i,k) <= qc_min(2)) then - ncpl(i,k) = 0.0 + ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) endif if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = 0.0 + ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) endif enddo enddo @@ -1592,19 +1593,19 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & QI_TOT(I,K) = QILS(I,K) + QICN(I,K) ! if (rnw(i,k) <= qc_min(1)) then - ncpl(i,k) = 0.0 - elseif (ncpl(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpl(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0), nmin) + ncpr(i,k) = zero + elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0d0), nmin) endif if (snw(i,k) <= qc_min(2)) then - ncpl(i,k) = 0.0 + ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) endif if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = 0.0 + ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) endif enddo enddo @@ -1618,8 +1619,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do K= 1, LM do I=1,IM - if (QI_TOT(i,k) <= 0.0) NCPI(i,k) = 0.0 - if (QL_TOT(i,k) <= 0.0) NCPL(i,k) = 0.0 + if (QI_TOT(i,k) <= zero) NCPI(i,k) = zero + if (QL_TOT(i,k) <= zero) NCPL(i,k) = zero end do end do @@ -1651,7 +1652,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & DO K=1, LM ll = lm-k+1 DO I = 1,IM - CLLS_io(i,k) = max(0.0, min(CLLS(i,ll)+CLCN(i,ll),1.0)) + CLLS_io(i,k) = max(zero, min(CLLS(i,ll)+CLCN(i,ll),one)) enddo enddo else @@ -1682,7 +1683,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & if (skip_macro) then DO K=1, LM DO I = 1,IM - CLLS_io(i,k) = max(0.0, min(CLLS(i,k)+CLCN(i,k),1.0)) + CLLS_io(i,k) = max(zero, min(CLLS(i,k)+CLCN(i,k),one)) enddo enddo else @@ -1696,12 +1697,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & DO I = 1,IM tx1 = LS_PRC2(i) + LS_SNR(i) - rn_o(i) = tx1 * dt_i * 0.001 + rn_o(i) = tx1 * dt_i * 0.001d0 if (rn_o(i) < rainmin) then - sr_o(i) = 0. + sr_o(i) = zero else - sr_o(i) = LS_SNR(i) / tx1 + sr_o(i) = max(zero, min(one, LS_SNR(i)/tx1)) endif ENDDO @@ -1833,7 +1834,7 @@ subroutine find_cldtop(ncol, pver, cf, kcldtop) ibot = pver-1 kcldtop = ibot+1 kuppest = 20 - cfcrit = 1e-2 + cfcrit = 1.0d-2 do k = kuppest , ibot diff --git a/gfsphysics/physics/micro_mg3_0.F90 b/gfsphysics/physics/micro_mg3_0.F90 index f27aa1896..89db1e34a 100644 --- a/gfsphysics/physics/micro_mg3_0.F90 +++ b/gfsphysics/physics/micro_mg3_0.F90 @@ -316,7 +316,7 @@ subroutine micro_mg_init( & !----------------------------------------------------------------------- - dcs = micro_mg_dcs * 1.0e-6 + dcs = micro_mg_dcs * 1.0d-6 ts_au_min = ts_auto(1) ts_au = ts_auto(2) qcvar = mg_qcvar @@ -1073,7 +1073,7 @@ subroutine micro_mg_tend ( & ! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.false. ! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & ! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & - real(r8), parameter :: qimax=0.010, qimin=0.005, qiinv=one/(qimax-qimin) + real(r8), parameter :: qimax=0.010_r8, qimin=0.005_r8, qiinv=one/(qimax-qimin) ! ts_au_min=180.0 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -3174,9 +3174,9 @@ subroutine micro_mg_tend ( & !++ag Add graupel dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat) * tx1 ! Moorthi testing - if (dumg(i,k) > 0.01) then - tx2 = dumg(i,k) - 0.01 - dumg(i,k) = 0.01 + if (dumg(i,k) > 0.01_r8) then + tx2 = dumg(i,k) - 0.01_r8 + dumg(i,k) = 0.01_r8 dums(i,k) = dums(i,k) + tx2 qstend(i,k) = (dums(i,k)*precip_frac(i,k) - qs(i,k)) * oneodt qgtend(i,k) = (dumg(i,k)*precip_frac(i,k) - qg(i,k)) * oneodt @@ -3778,9 +3778,9 @@ subroutine micro_mg_tend ( & !++ag dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) ! Moorthi testing - if (dumg(i,k) > 0.01) then - tx2 = dumg(i,k) - 0.01 - dumg(i,k) = 0.01 + if (dumg(i,k) > 0.01_r8) then + tx2 = dumg(i,k) - 0.01_r8 + dumg(i,k) = 0.01_r8 dums(i,k) = dums(i,k) + tx2 qstend(i,k) = (dums(i,k) - qs(i,k)) * oneodt qgtend(i,k) = (dumg(i,k) - qg(i,k)) * oneodt @@ -4029,7 +4029,7 @@ subroutine micro_mg_tend ( & ! qvn = epsqs*esn/(p(i,k)-omeps*esn) - if (qtmp > qvn .and. qvn > 0 .and. allow_sed_supersat) then + if (qtmp > qvn .and. qvn > zero .and. allow_sed_supersat) then ! expression below is approximate since there may be ice deposition dum = (qtmp-qvn)/(one+xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) * oneodt ! add to output cme diff --git a/gfsphysics/physics/micro_mg_utils.F90 b/gfsphysics/physics/micro_mg_utils.F90 index ab20ec7cf..53518bef7 100644 --- a/gfsphysics/physics/micro_mg_utils.F90 +++ b/gfsphysics/physics/micro_mg_utils.F90 @@ -480,10 +480,10 @@ elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc if (liq_gmao) then pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 ! Anning modified lamc - if ((ncic > 1.0e-3) .and. (qcic > 1.0e-11)) then + if ((ncic > 1.0e-3_r8) .and. (qcic > 1.0e-11_r8)) then xs = 0.07_r8*(1000._r8*qcic/ncic) ** (-0.14_r8) else - xs = 1.2 + xs = 1.2_r8 end if xs = max(min(xs, 1.7_r8), 1.1_r8) @@ -549,15 +549,15 @@ subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) if (liq_gmao) then pgam(i) = 0.0005714_r8*1.e-6_r8*ncic(i)*rho(i) + 0.2714_r8 - if ((ncic(i) > 1.0e-3) .and. (qcic(i) > 1.0e-11)) then + if ((ncic(i) > 1.0e-3_r8) .and. (qcic(i) > 1.0e-11_r8)) then xs = 0.07_r8*(1000._r8*qcic(i)/ncic(i)) **(-0.14_r8) else - xs = 1.2 + xs = 1.2_r8 end if xs = max(min(xs, 1.7_r8), 1.1_r8) xs = xs*xs*xs - xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.)/8.0_r8 + xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.0_r8)/8.0_r8 pgam(i) = sqrt(xs) else pgam(i) = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic(i)*rho(i)) @@ -707,12 +707,12 @@ elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) miu_ice = max(min(0.008_r8*(lam*0.01)**0.87_r8, 10.0_r8), 0.1_r8) tx1 = 1. + miu_ice tx2 = 1. / gamma(tx1) - aux = (gamma(tx1+3.)*tx2) ** (1./3.) + aux = (gamma(tx1+3.0_r8)*tx2) ** (1.0_r8/3.0_r8) lam = lam*aux else - aux = 1. - tx1 = 1.0 - tx2 = 1.0 + aux = 1.0_r8 + tx1 = 1.0_r8 + tx2 = 1.0_r8 end if if (present(n0)) n0 = nic * lam**tx1*tx2 @@ -729,7 +729,7 @@ elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) end if else - lam = 0._r8 + lam = 0.0_r8 end if @@ -762,14 +762,14 @@ subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) lam(i) = (props%shape_coef * nic(i)/qic(i))**(1._r8/props%eff_dim) if (ice_sep) then miu_ice = max(min(0.008_r8*(lam(i)*0.01)**0.87_r8, 10.0_r8), 0.1_r8) - tx1 = 1. + miu_ice - tx2 = 1. / gamma(tx1) - aux = (gamma(tx1+3.)*tx2) ** (1./3.) + tx1 = 1.0_r8 + miu_ice + tx2 = 1.0_r8 / gamma(tx1) + aux = (gamma(tx1+3.0_r8)*tx2) ** (1.0_r8/3.0_r8) lam(i) = lam(i)*aux else - aux = 1. - tx1 = 1.0 - tx2 = 1.0 + aux = 1.0_r8 + tx1 = 1.0_r8 + tx2 = 1.0_r8 end if if (present(n0)) n0(i) = nic(i) * lam(i)**tx1*tx2 @@ -786,7 +786,7 @@ subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) end if else - lam(i) = 0._r8 + lam(i) = 0.0_r8 end if enddo @@ -1103,10 +1103,10 @@ subroutine liu_liq_autoconversion(pgam,qc,nc,qr,rho,relvar, & LW = 1.0e-3_r8 * qc(i) * rho(i) NW = nc(i) * rho(i) * 1.e-6_r8 - xs = min(20.0, 1.03e16*(LW*LW)/(NW*SQRT(NW))) - au(i) = 1.1e10*beta6*LW*LW*LW & + xs = min(20.0_r8, 1.03e16_r8*(LW*LW)/(NW*SQRT(NW))) + au(i) = 1.1e10_r8*beta6*LW*LW*LW & * (one-exp(-(xs**miu_disp))) / NW - au(i) = au(i)*1.0e3/rho(i) + au(i) = au(i)*1.0e3_r8/rho(i) au(i) = au(i) * gamma(two+relvar(i)) & / (gamma(relvar(i))*(relvar(i)*relvar(i))) @@ -2156,7 +2156,7 @@ subroutine graupel_collecting_snow(qsic,qric,umr,ums,rho,lamr,n0r,lams,n0s, & tx5 = tx4 * tx4 * tx3 psacr(i) = cons31 * tx1 * rho(i) * n0r(i) * n0s(i) * tx5 & - * (5.0*tx4+tx3*(tx2+tx2+0.5*tx3)) + * (5.0_r8*tx4+tx3*(tx2+tx2+0.5_r8*tx3)) ! psacr(i) = cons31*(((1.2_r8*umr(i)-0.95_r8*ums(i))**2+ & ! 0.08_r8*ums(i)*umr(i))**0.5_r8*rho(i)* & @@ -2208,7 +2208,7 @@ subroutine graupel_collecting_cld_water(qgic,qcic,ncic,rho,n0g,lamg,bg,agn, & do i=1,mgncol - if (qgic(i) >= 1.e-8 .and. qcic(i) >= qsmall) then + if (qgic(i) >= 1.e-8_r8 .and. qcic(i) >= qsmall) then tx1 = cons*agn(i)*rho(i)*n0g(i) / lamg(i)**(bg+three) @@ -2353,8 +2353,8 @@ subroutine graupel_collecting_rain(qric,qgic,umg,umr,ung,unr,rho,n0r,lamr,n0g,la ! pracg is mixing ratio of rain per sec collected by graupel/hail tx1 = 1.2_r8*umr(i) - 0.95_r8*umg(i) tx1 = sqrt(tx1*tx1+0.08_r8*umg(i)*umr(i)) - tx2 = 1.0 / lamr(i) - tx3 = 1.0 / lamg(i) + tx2 = 1.0_r8 / lamr(i) + tx3 = 1.0_r8 / lamg(i) tx4 = tx2 * tx2 tx5 = tx4 * tx4 * tx3 tx6 = rho(i) * n0r(i) * n0g(i) @@ -2717,10 +2717,10 @@ FUNCTION gamma_incomp(muice, x) real(r8) :: gamma_incomp REAL(r8), intent(in) :: muice, x REAL(r8) :: xog, kg, alfa, auxx - alfa = min(max(muice+1., 1.), 20._r8) + alfa = min(max(muice+1._r8, 1._r8), 20._r8) xog = log(alfa -0.3068_r8) - kg = 1.44818*(alfa**0.5357_r8) + kg = 1.44818_r8*(alfa**0.5357_r8) auxx = max(min(kg*(log(x)-xog), 30._r8), -30._r8) gamma_incomp = max(one/(one+exp(-auxx)), 1.0e-20) diff --git a/gfsphysics/physics/moninshoc.f b/gfsphysics/physics/moninshoc.f index d68c001b5..20a2adccc 100644 --- a/gfsphysics/physics/moninshoc.f +++ b/gfsphysics/physics/moninshoc.f @@ -65,16 +65,17 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, &, ttend, utend, vtend, qtend &, spdk2, rbint, ri, zol1, robn, bvf2 ! - real(kind=kind_phys), parameter :: gravi=1.0/grav, zolcr=0.2, - & zolcru=-0.5, rimin=-100., sfcfrac=0.1, - & crbcon=0.25, crbmin=0.15, crbmax=0.35, - & qmin=1.e-8, zfmin=1.e-8, qlmin=1.e-12, - & aphi5=5., aphi16=16., f0=1.e-4 - &, cont=cp/grav, conq=hvap/grav, conw=1.0/grav - &, dkmin=0.0, dkmax=1000. -! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 - &, gocp=grav/cp, prmin=0.25, prmax=4.0 - &, vk=0.4, cfac=6.5 + real(kind=kind_phys), parameter :: one=1.0d0, zero=0.0d0 + &, gravi=one/grav, zolcr=0.2d0 + &, zolcru=-0.5d0, rimin=-100.0d0, sfcfrac=0.1d0 + &, crbcon=0.25d0, crbmin=0.15d0, crbmax=0.35d0 + &, qmin=1.0d-8, zfmin=1.0d-8, qlmin=1.0d-12 + &, aphi5=5.0d0, aphi16=16.0d0, f0=1.0d-4 + &, cont=cp/grav, conq=hvap/grav, conw=one/grav + &, dkmin=zero, dkmax=1000.0d0 +! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 + &, gocp=grav/cp, prmin=0.25d0, prmax=4.0d0 + &, vk=0.4d0, cfac=6.5d0 ! !----------------------------------------------------------------------- ! @@ -108,24 +109,24 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! do k = 1,km1 do i=1,im - rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) - prnum(i,k) = 1.0 + rdzt(i,k) = one / (zl(i,k+1) - zl(i,k)) + prnum(i,k) = one enddo enddo ! Setup backgrond diffision do i=1,im - prnum(i,km) = 1.0 - tx1(i) = 1.0 / prsi(i,1) + prnum(i,km) = one + tx1(i) = one / prsi(i,1) enddo do k = 1,km1 do i=1,im - xkzo(i,k) = 0.0 - xkzmo(i,k) = 0.0 + xkzo(i,k) = zero + xkzmo(i,k) = zero ! if (k < kinver(i)) then if (k <= kinver(i)) then ! vertical background diffusivity for heat and momentum - tem1 = 1.0 - prsi(i,k+1) * tx1(i) - tem1 = min(1.0, exp(-tem1 * tem1 * 10.0)) + tem1 = one - prsi(i,k+1) * tx1(i) + tem1 = min(one, exp(-tem1 * tem1 * 10.0d0)) xkzo(i,k) = xkzm_h * tem1 xkzmo(i,k) = xkzm_m * tem1 endif @@ -141,9 +142,9 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! do k = 1,kmpbl do i=1,im - if(zi(i,k+1) > 250.) then + if(zi(i,k+1) > 250.0d0) then tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 > 1.e-5) then + if(tem1 > 1.0d-5) then xkzo(i,k) = min(xkzo(i,k),xkzminv) endif endif @@ -152,21 +153,21 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! ! do i = 1,im - z0(i) = 0.01 * zorl(i) + z0(i) = 0.01d0 * zorl(i) kpbl(i) = 1 hpbl(i) = zi(i,1) pblflg(i) = .true. sfcflg(i) = .true. - if(rbsoil(i) > 0.) sfcflg(i) = .false. - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. + if(rbsoil(i) > zero) sfcflg(i) = .false. + dusfc(i) = zero + dvsfc(i) = zero + dtsfc(i) = zero + dqsfc(i) = zero enddo ! do k = 1,km do i=1,im - tx1(i) = 0.0 + tx1(i) = zero enddo do kk=1,ncnd do i=1,im @@ -182,7 +183,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! if (lprnt) write(0,*)' heat=',heat(ipr),' evap=',evap(ipr) do i = 1,im sflux(i) = heat(i) + evap(i)*fv*theta(i,1) - if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + if(.not.sfcflg(i) .or. sflux(i) <= zero) pblflg(i)=.false. beta(i) = dt2 / (zi(i,2)-zi(i,1)) enddo ! @@ -197,11 +198,11 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, thermal(i) = thvx(i,1) crb(i) = crbcon else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - tem = max(1.0, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i))) + thermal(i) = tsea(i)*(one+fv*max(q1(i,1,1),qmin)) + tem = max(one, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i))) robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn - crb(i) = max(min(0.16 * (tem1 ** (-0.18)), crbmax), crbmin) + tem1 = 1.0d-7 * robn + crb(i) = max(min(0.16d0 * (tem1**(-0.18d0)), crbmax), crbmin) endif enddo do k = 1, kmpbl @@ -220,9 +221,9 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, if(kpbl(i) > 1) then k = kpbl(i) if(rbdn(i) >= crb(i)) then - rbint = 0. + rbint = zero elseif(rbup(i) <= crb(i)) then - rbint = 1. + rbint = one else rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i)) endif @@ -245,13 +246,13 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, endif zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) if(sfcflg(i)) then -! phim(i) = (1.-aphi16*zol1)**(-1./4.) -! phih(i) = (1.-aphi16*zol1)**(-1./2.) - tem = 1.0 / max(1. - aphi16*zol1, 1.0e-8) +! phim(i) = (1.-aphi16*zol1)**(-one/4.0d0) +! phih(i) = (1.-aphi16*zol1)**(-one/2.0d0) + tem = one / max(one - aphi16*zol1, 1.0d-8) phih(i) = sqrt(tem) phim(i) = sqrt(phih(i)) else - phim(i) = 1. + aphi5*zol1 + phim(i) = one + aphi5*zol1 phih(i) = phim(i) endif enddo @@ -269,7 +270,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, do i = 1, im if(.not.flg(i)) then rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), 1.) + spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), one) rbup(i) = (thvx(i,k)-thermal(i)) * phil(i,k) & / (thvx(i,1)*spdk2) kpbl(i) = k @@ -281,9 +282,9 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, if (pblflg(i)) then k = kpbl(i) if(rbdn(i) >= crb(i)) then - rbint = 0. + rbint = zero elseif(rbup(i) <= crb(i)) then - rbint = 1. + rbint = one else rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i)) endif @@ -321,13 +322,13 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, tem = u1(i,k) - u1(i,kp1) tem1 = v1(i,k) - v1(i,kp1) tem = (tem*tem + tem1*tem1) * rdz * rdz - bvf2 = (0.5*grav)*(thvx(i,kp1)-thvx(i,k))*rdz + bvf2 = (0.5d0*grav)*(thvx(i,kp1)-thvx(i,k))*rdz & / (t1(i,k)+t1(i,kp1)) ri = max(bvf2/tem,rimin) - if(ri < 0.) then ! unstable regime - prnum(i,kp1) = 1.0 + if(ri < zero) then ! unstable regime + prnum(i,kp1) = one else - prnum(i,kp1) = min(1.0 + 2.1*ri, prmax) + prnum(i,kp1) = min(one + 2.1d0*ri, prmax) endif elseif (k > 1) then prnum(i,kp1) = prnum(i,1) @@ -437,7 +438,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! compute tridiagonal matrix elements for momentum ! do i=1,im - ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) + ad(i,1) = one + beta(i) * stress(i) / spd1(i) a1(i,1) = u1(i,1) a2(i,1) = v1(i,1) enddo @@ -455,7 +456,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, al(i,k) = -dtodsu*dsdz2 ! ad(i,k) = ad(i,k) - au(i,k) - ad(i,kp1) = 1.0 - al(i,k) + ad(i,kp1) = one - al(i,k) a1(i,kp1) = u1(i,kp1) a2(i,kp1) = v1(i,kp1) ! @@ -482,7 +483,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! compute tridiagonal matrix elements for tke ! do i=1,im - ad(i,1) = 1.0 + ad(i,1) = one a1(i,1) = q1(i,1,ntke) enddo ! @@ -499,7 +500,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, al(i,k) = -dtodsu*dsdz2 ! ad(i,k) = ad(i,k) - au(i,k) - ad(i,kp1) = 1.0 - al(i,k) + ad(i,kp1) = one - al(i,k) a1(i,kp1) = q1(i,kp1,ntke) enddo enddo @@ -522,26 +523,28 @@ subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) ! use machine , only : kind_phys implicit none - integer k,n,l,i - real(kind=kind_phys) fk + real(kind=kind_phys), parameter :: one=1.0d0 ! real(kind=kind_phys) cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n), & & au(l,n-1),a1(l,n) +! + real(kind=kind_phys) fk + integer k,n,l,i ! do i=1,l - fk = 1./cm(i,1) + fk = one / cm(i,1) au(i,1) = fk*cu(i,1) a1(i,1) = fk*r1(i,1) enddo do k=2,n-1 do i=1,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + fk = one / (cm(i,k)-cl(i,k)*au(i,k-1)) au(i,k) = fk*cu(i,k) a1(i,k) = fk*(r1(i,k)-cl(i,k)*a1(i,k-1)) enddo enddo do i=1,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + fk = one / (cm(i,n)-cl(i,n)*au(i,n-1)) a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(i,n-1)) enddo do k=n-1,1,-1 diff --git a/gfsphysics/physics/rascnvv2.f b/gfsphysics/physics/rascnvv2.f index 3e70d57eb..413a1b553 100644 --- a/gfsphysics/physics/rascnvv2.f +++ b/gfsphysics/physics/rascnvv2.f @@ -9,25 +9,25 @@ module module_ras integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s integer, parameter :: idnmax=999 - real (kind=kind_phys), parameter :: delt_c=1800.0/3600.0 & + real (kind=kind_phys), parameter :: delt_c=1800.0d0/3600.0d0 & ! Adjustment time scales in hrs for deep and shallow clouds ! &, adjts_d=3.0, adjts_s=0.5 ! &, adjts_d=2.5, adjts_s=0.5 - &, adjts_d=2.0, adjts_s=0.5 + &, adjts_d=2.0d0, adjts_s=0.5d0 ! logical, parameter :: fix_ncld_hr=.true. ! - real (kind=kind_phys), parameter :: ZERO=0.0, HALF=0.5 & - &, pt25=0.25 & - &, ONE=1.0, TWO=2.0, FOUR=4.& - &, twoo3=two/3.0 & - &, FOUR_P2=4.E2, ONE_M10=1.E-10 & - &, ONE_M6=1.E-6, ONE_M5=1.E-5 & - &, ONE_M2=1.E-2, ONE_M1=1.E-1 & - &, oneolog10=one/log(10.0) & - &, cfmax=0.1 & + real (kind=kind_phys), parameter :: ZERO=0.0d0, HALF=0.5d0 & + &, pt25=0.25d0, ONE=1.0d0 & + &, TWO=2.0d0, FOUR=4.0d0 & + &, twoo3=two/3.0d0 & + &, FOUR_P2=4.d2, ONE_M10=1.0d-10& + &, ONE_M6=1.0d-6, ONE_M5=1.0d-5 & + &, ONE_M2=1.0d-2, ONE_M1=1.0d-1 & + &, oneolog10=one/log(10.0d0) & + &, cfmax=0.1d0 & &, deg2rad=pi/180.d0 & ! conversion factor from degree to radians - &, cmb2pa = 100.0 ! Conversion from hPa to Pa + &, cmb2pa = 100.0d0 ! Conversion from hPa to Pa ! real(kind=kind_phys), parameter :: & & ONEBG = ONE / GRAV, GRAVCON = cmb2pa * ONEBG & @@ -36,15 +36,15 @@ module module_ras &, ELFOCP = (ALHL+ALHF) * onebcp & &, oneoalhl = one/alhl & &, CMPOR = CMB2PA / RGAS & - &, picon = half*pi*onebg, VTPEXP = -0.3636 & - &, dpnegcr = 150.0 & + &, picon = half*pi*onebg, VTPEXP = -0.3636d0 & + &, dpnegcr = 150.0d0 & ! &, dpnegcr = 100.0 & ! &, dpnegcr = 200.0 & ! &, ddunc1 = 0.4, ddunc2=one-ddunc1 & uncentering for vvel in dd - &, ddunc1 = 0.25, ddunc2=one-ddunc1 & uncentering for vvel in dd + &, ddunc1 = 0.25d0, ddunc2=one-ddunc1 & uncentering for vvel in dd ! &, ddunc1 = 0.3, ddunc2=one-ddunc1 & uncentering for vvel in dd - &, zfac = 0.28888889E-4 * ONEBG - &, c0ifac = 0.07 ! following Han et al, 2016 MWR + &, zfac = 0.28888889d-4 * ONEBG + &, c0ifac = 0.07d0 ! following Han et al, 2016 MWR ! ! logical, parameter :: advcld=.true., advups=.true., advtvd=.false. logical, parameter :: advcld=.true., advups=.false., advtvd=.true. @@ -56,16 +56,16 @@ module module_ras &, testmboalhl, testmbi ! PARAMETER (DD_DP=0.0, RKNOB=1.0, EKNOB=1.0) ! No downdraft! - PARAMETER (DD_DP=0.5, RKNOB=1.0, EKNOB=1.0) + PARAMETER (DD_DP=0.5d0, RKNOB=1.0d0, EKNOB=1.0d0) ! PARAMETER (DD_DP=0.5, RKNOB=2.0, EKNOB=1.0) ! - PARAMETER (RHMAX=1.0 ) ! MAX RELATIVE HUMIDITY - PARAMETER (QUAD_LAM=1.0) ! MASK FOR QUADRATIC LAMBDA -! PARAMETER (RHRAM=0.15) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (RHRAM=0.05) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (HCRITD=4000.0) ! Critical Moist Static Energy for Deep clouds - PARAMETER (HCRITS=2000.0) ! Critical Moist Static Energy for Shallow Clouds - PARAMETER (pcrit_lcl=250.0)! Critical pressure difference between boundary layer top + PARAMETER (RHMAX=1.0d0 ) ! MAX RELATIVE HUMIDITY + PARAMETER (QUAD_LAM=1.0d0) ! MASK FOR QUADRATIC LAMBDA +! PARAMETER (RHRAM=0.15) ! PBL RELATIVE HUMIDITY RAMP + PARAMETER (RHRAM=0.05d0) ! PBL RELATIVE HUMIDITY RAMP + PARAMETER (HCRITD=4000.0d0) ! Critical Moist Static Energy for Deep clouds + PARAMETER (HCRITS=2000.0d0) ! Critical Moist Static Energy for Shallow Clouds + PARAMETER (pcrit_lcl=250.0d0)! Critical pressure difference between boundary layer top ! and lifting condensation level (hPa) ! parameter (hpert_fac=1.01) ! Perturbation on hbl when ctei=.true. @@ -73,15 +73,15 @@ module module_ras ! parameter (hpert_fac=1.00) ! Perturbation on hbl when ctei=.true. ! parameter (qudfac=quad_lam*half, shalfac=1.0) ! parameter (qudfac=quad_lam*half, shalfac=2.0) - parameter (qudfac=quad_lam*half, shalfac=3.0) + parameter (qudfac=quad_lam*half, shalfac=3.0d0) ! parameter (qudfac=quad_lam*pt25) ! Yogesh's - parameter (testmb=0.1, testmbi=one/testmb) + parameter (testmb=0.1d0, testmbi=one/testmb) parameter (testmboalhl=testmb/alhl) ! real(kind=kind_phys) facdt - real(kind=kind_phys), parameter :: almax=1.0e-2 - &, almin1=0.0, almin2=0.0 + real(kind=kind_phys), parameter :: almax=1.0d-2 + &, almin1=0.0d0, almin2=0.0d0 ! real(kind=kind_phys) ALMIN1, ALMIN2, ALMAX ! @@ -91,7 +91,7 @@ module module_ras !cnt PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=5.0E-3) ! ! real(kind=kind_phys), parameter :: BLDMAX = 200.0 - real(kind=kind_phys), parameter :: BLDMAX = 300.0, bldmin=25.0 + real(kind=kind_phys), parameter :: BLDMAX = 300.0d0, bldmin=25.0d0 !! real(kind=kind_phys), parameter :: BLDMAX = 350.0 ! ! @@ -100,7 +100,7 @@ module module_ras ! parameter (TF=230.16, TCR=260.16, TCRF=1.0/(TCR-TF)) ! parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF),TCL=2.0) ! parameter (TF=258.16, TCR=273.16, TCRF=1.0/(TCR-TF),TCL=2.0) - parameter (TF=233.16, TCR=273.16, TCRF=1.0/(TCR-TF),TCL=2.0) + parameter (TF=233.16d0, TCR=273.16d0, TCRF=one/(TCR-TF),TCL=2.0d0) ! ! For Tilting Angle Specification ! @@ -127,7 +127,7 @@ subroutine set_ras_afc(dt) implicit none real(kind=kind_phys) DT ! AFC = -(1.04E-4*DT)*(3600./DT)**0.578 - AFC = -(1.01097E-4*DT)*(3600./DT)**0.57777778 + AFC = -(1.01097d-4*DT)*(3600.0d0/DT)**0.57777778d0 end subroutine set_ras_afc subroutine ras_init(levs, me) @@ -178,7 +178,7 @@ subroutine ras_init(levs, me) drdp(i) = (REFR(i+1)-REFR(i)) / (REFP(i+1)-REFP(i)) enddo ! - VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 + VTP = 36.34d0*SQRT(1.2d0)* (0.001d0)**0.1364d0 ! if (me == 0) write(0,*) ' NO DOWNDRAFT FOR CLOUD TYPES' & &, ' DETRAINING AT NORMALIZED PRESSURE ABOVE ',DD_DP @@ -198,12 +198,12 @@ module module_rascnv LOGICAL WRKFUN, CALKBL, CRTFUN, UPDRET, BOTOP, vsmooth, do_aw & &, CUMFRC - real(kind=kind_phys), parameter :: frac=0.5, crtmsf=0.0 & - &, rhfacs=0.75, rhfacl=0.75 & + real(kind=kind_phys), parameter :: frac=0.5d0, crtmsf=0.0d0 & + &, rhfacs=0.75d0, rhfacl=0.75d0 & ! &, rhfacs=0.70, rhfacl=0.70 & - &, face=5.0, delx=10000.0 & - &, ddfac=face*delx*0.001 & - &, max_neg_bouy=0.15 + &, face=5.0d0, delx=10000.0d0 & + &, ddfac=face*delx*0.001d0 & + &, max_neg_bouy=0.15d0 ! &, max_neg_bouy=pt25 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -219,9 +219,9 @@ module module_rascnv ! For pressure gradient force in momentum mixing ! real (kind=kind_phys), parameter :: pgftop=0.80, pgfbot=0.30 & ! No pressure gradient force in momentum mixing - real (kind=kind_phys), parameter :: pgftop=0.0, pgfbot=0.0 & + real (kind=kind_phys), parameter :: pgftop=0.0d0, pgfbot=0.0d0 & ! real (kind=kind_phys), parameter :: pgftop=0.55, pgfbot=0.55 & - &, pgfgrad=(pgfbot-pgftop)*0.001 + &, pgfgrad=(pgfbot-pgftop)*0.001d0 ! end module module_rascnv ! @@ -306,7 +306,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & integer, dimension(100) :: ic - real(kind=kind_phys), parameter :: clwmin=1.0e-10 + real(kind=kind_phys), parameter :: clwmin=1.0d-10 ! real(kind=kind_phys), allocatable :: ALFINT(:,:), uvi(:,:) &, trcfac(:,:), rcu(:,:) @@ -431,16 +431,16 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & if (flipv) ll = kp1 -l ! Input variables are bottom to top! SGC = prsl(ipt,ll) * tem sgcs(l,ipt) = sgc - IF (SGC <= 0.050) KRMIN = L -! IF (SGC <= 0.700) KRMAX = L -! IF (SGC <= 0.800) KRMAX = L - IF (SGC <= 0.760) KRMAX = L -! IF (SGC <= 0.930) KFMAX = L - IF (SGC <= 0.970) KFMAX = L ! Commented on 20060202 -! IF (SGC <= 0.700) kblmx = L ! Commented on 20101015 - IF (SGC <= 0.600) kblmx = L ! -! IF (SGC <= 0.650) kblmx = L ! Commented on 20060202 - IF (SGC <= 0.980) kblmn = L ! + IF (SGC <= 0.050d0) KRMIN = L +! IF (SGC <= 0.700d0) KRMAX = L +! IF (SGC <= 0.800d0) KRMAX = L + IF (SGC <= 0.760d0) KRMAX = L +! IF (SGC <= 0.930d0) KFMAX = L + IF (SGC <= 0.970d0) KFMAX = L ! Commented on 20060202 +! IF (SGC <= 0.700d0) kblmx = L ! Commented on 20101015 + IF (SGC <= 0.600d0) kblmx = L ! +! IF (SGC <= 0.650d0) kblmx = L ! Commented on 20060202 + IF (SGC <= 0.980d0) kblmn = L ! ENDDO krmin = max(krmin,2) @@ -450,7 +450,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! if (fix_ncld_hr) then !!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 - NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1800) + 0.10001 + NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1800) + 0.10001d0 ! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.10001 ! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/900) + 0.50001 ! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/600) + 0.50001 @@ -460,7 +460,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & facdt = delt_c / dt else NCRND = min(nrcmax, (KRMAX-KRMIN+1)) - facdt = one / 3600.0 + facdt = one / 3600.0d0 endif NCRND = min(nrcm,max(NCRND, 1)) ! @@ -489,7 +489,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & IF (NCRND > 0) THEN DO I=1,NCRND II = mod(i-1,nrcm) + 1 - IRND = (RANNUM(ipt,II)-0.0005)*(KCR-KRMIN+1) + IRND = (RANNUM(ipt,II)-0.0005d0)*(KCR-KRMIN+1) IC(KFX+I) = IRND + KRMIN ENDDO ENDIF @@ -547,7 +547,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & if (trac > 0) then ! tracers such as O3, dust etc do n=1,trac uvi(l,n) = ccin(ipt,ll,n+2) - if (abs(uvi(l,n)) < 1.0e-20) uvi(l,n) = zero + if (abs(uvi(l,n)) < 1.0d-20) uvi(l,n) = zero enddo endif enddo @@ -558,7 +558,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & phi_h(LL) = phii(ipt,L) enddo ! - if (ccin(ipt,1,2) <= -999.0) then ! input ice/water are together + if (ccin(ipt,1,2) <= -999.0d0) then ! input ice/water are together do l=1,k ll = kp1 -l tem = ccin(ipt,ll,1) & @@ -596,7 +596,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & if (trac > 0) then ! tracers such as O3, dust etc do n=1,trac uvi(l,n) = ccin(ipt,l,n+2) - if (abs(uvi(l,n)) < 1.0e-20) uvi(l,n) = zero + if (abs(uvi(l,n)) < 1.0d-20) uvi(l,n) = zero enddo endif enddo @@ -606,7 +606,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & phi_h(L) = phii(ipt,L) ENDDO ! - if (ccin(ipt,1,2) <= -999.0) then ! input ice/water are together + if (ccin(ipt,1,2) <= -999.0d0) then ! input ice/water are together do l=1,k tem = ccin(ipt,l,1) & & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) @@ -664,7 +664,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvd=',dtvd(:,1) - if (abs(dtvd(2,1)) > 1.0e-10) then + if (abs(dtvd(2,1)) > 1.0d-10) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) alfint(l,1) = one - half*(tem1 + tem2)/(one + tem2) ! for h @@ -678,7 +678,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvd2=',dtvd(:,2) - if (abs(dtvd(2,2)) > 1.0e-10) then + if (abs(dtvd(2,2)) > 1.0d-10) then tem1 = dtvd(1,2) / dtvd(2,2) tem2 = abs(tem1) alfint(l,2) = one - half*(tem1 + tem2)/(one + tem2) ! for q @@ -689,7 +689,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvd3=',dtvd(:,3) - if (abs(dtvd(2,3)) > 1.0e-10) then + if (abs(dtvd(2,3)) > 1.0d-10) then tem1 = dtvd(1,3) / dtvd(2,3) tem2 = abs(tem1) alfint(l,3) = one - half*(tem1 + tem2)/(one + tem2) ! for ql @@ -700,7 +700,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvd4=',dtvd(:,4) - if (abs(dtvd(2,4)) > 1.0e-10) then + if (abs(dtvd(2,4)) > 1.0d-10) then tem1 = dtvd(1,4) / dtvd(2,4) tem2 = abs(tem1) alfint(l,4) = one - half*(tem1 + tem2)/(one + tem2) ! for qi @@ -717,7 +717,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvdn=',dtvd(:,1),' n=',n,' l=',l - if (abs(dtvd(2,1)) > 1.0e-10) then + if (abs(dtvd(2,1)) > 1.0d-10) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) alfint(l,n+4) = one - half*(tem1 + tem2)/(one + tem2) ! for tracers @@ -859,7 +859,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*) ' qiiin=',qii ! endif ! - TLA = -10.0 + TLA = -10.0d0 ! qiid = qii(ib) ! cloud top level ice before convection qlid = qli(ib) ! cloud top level water before convection @@ -975,7 +975,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! ENDDO ! End of the NC loop! ! - RAINC(ipt) = rain * 0.001 ! Output rain is in meters + RAINC(ipt) = rain * 0.001d0 ! Output rain is in meters ! if (lprint) then ! write(0,*) ' convective precip=',rain*86400/dt,' mm/day' @@ -998,9 +998,9 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! clw(i) = max(clw(i), zero) ! cli(i) = max(cli(i), zero) - if (sgcs(l,ipt) < 0.93 .and. abs(tcu(l)) > one_m10) then -! if (sgcs(l,ipt) < 0.90 .and. tcu(l) .ne. 0.0) then -! if (sgcs(l,ipt) < 0.85 .and. tcu(l) .ne. 0.0) then + if (sgcs(l,ipt) < 0.93d0 .and. abs(tcu(l)) > one_m10) then +! if (sgcs(l,ipt) < 0.90d0 .and. tcu(l) .ne. 0.0) then +! if (sgcs(l,ipt) < 0.85d0 .and. tcu(l) .ne. 0.0) then kcnv(ipt) = 1 endif ! New test for convective clouds ! added in 08/21/96 @@ -1026,23 +1026,23 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & QLCN(ipt,ll) = max(qli(l)-ccin(ipt,ll,2), zero) QICN(ipt,ll) = max(qii(l)-ccin(ipt,ll,1), zero) CNV_FICE(ipt,ll) = QICN(ipt,ll) - & / max(1.e-10,QLCN(ipt,ll)+QICN(ipt,ll)) + & / max(1.d-10,QLCN(ipt,ll)+QICN(ipt,ll)) else QLCN(ipt,ll) = qli(l) QICN(ipt,ll) = qii(l) - CNV_FICE(ipt,ll) = qii(l)/max(1.e-10,qii(l)+qli(l)) + CNV_FICE(ipt,ll) = qii(l)/max(1.d-10,qii(l)+qli(l)) endif !! CNV_PRC3(ipt,ll) = PCU(l)/dt ! CNV_PRC3(ipt,ll) = zero ! if(PCU(l) < zero) write(*,*)"AAA777",PCU(l),ipt,ll - cf_upi(ipt,ll) = max(zero,min(0.02*log(one+ - & 500*ud_mf(ipt,ll)/dt), cfmax)) + cf_upi(ipt,ll) = max(zero,min(0.02d0*log(one+ + & 500.0d0*ud_mf(ipt,ll)/dt), cfmax)) ! & 500*ud_mf(ipt,ll)/dt), 0.60)) ! if (lprint) write(0,*)' ll=',ll,' cf_upi=',cf_upi(ipt,ll) ! &,' ud_mf=',ud_mf(ipt,ll),' dt=',dt,' cfmax=',cfmax CLCN(ipt,ll) = cf_upi(ipt,ll) !downdraft is below updraft w_upi(ipt,ll) = ud_mf(ipt,ll)*toi(l)*rgas / - & (dt*max(cf_upi(ipt,ll),1.e-12)*prsl(ipt,ll)) + & (dt*max(cf_upi(ipt,ll),1.d-12)*prsl(ipt,ll)) endif if (trac > 0) then @@ -1087,21 +1087,21 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & QLCN(ipt,l) = max(qli(l)-ccin(ipt,l,2), zero) QICN(ipt,l) = max(qii(l)-ccin(ipt,l,1), zero) CNV_FICE(ipt,l) = QICN(ipt,l) - & / max(1.e-10,QLCN(ipt,l)+QICN(ipt,l)) + & / max(1.d-10,QLCN(ipt,l)+QICN(ipt,l)) else QLCN(ipt,l) = qli(l) QICN(ipt,l) = qii(l) - CNV_FICE(ipt,l) = qii(l)/max(1.e-10,qii(l)+qli(l)) + CNV_FICE(ipt,l) = qii(l)/max(1.d-10,qii(l)+qli(l)) endif !! CNV_PRC3(ipt,l) = PCU(l)/dt ! CNV_PRC3(ipt,l) = zero ! if(PCU(l) < zero) write(*,*)"AAA777",PCU(l),ipt,l - cf_upi(ipt,l) = max(zero,min(0.02*log(one+ - & 500*ud_mf(ipt,l)/dt), cfmax)) + cf_upi(ipt,l) = max(zero,min(0.02d0*log(one+ + & 500.0d0*ud_mf(ipt,l)/dt), cfmax)) ! & 500*ud_mf(ipt,l)/dt), 0.60)) CLCN(ipt,l) = cf_upi(ipt,l) !downdraft is below updraft w_upi(ipt,l) = ud_mf(ipt,l)*toi(l)*rgas / - & (dt*max(cf_upi(ipt,l),1.e-12)*prsl(ipt,l)) + & (dt*max(cf_upi(ipt,l),1.d-12)*prsl(ipt,l)) endif if (trac > 0) then @@ -1152,7 +1152,7 @@ SUBROUTINE CRTWRK(PL, CCWF, ACR) real(kind=kind_phys) PL, CCWF, ACR INTEGER IWK ! - IWK = PL * 0.02 - 0.999999999 + IWK = PL * 0.02d0 - 0.999999999d0 IWK = MAX(1, MIN(IWK,16)) ACR = (AC(IWK) + PL * AD(IWK)) * CCWF ! @@ -1260,12 +1260,12 @@ SUBROUTINE CLOUD( & real(kind=kind_phys), dimension(K,NTRC) :: RCU real(kind=kind_phys) :: CUP ! - real(kind=kind_phys), parameter :: ERRMIN=0.0001 & - &, ERRMI2=0.1*ERRMIN & + real(kind=kind_phys), parameter :: ERRMIN=0.0001d0 & + &, ERRMI2=0.1d0*ERRMIN & ! &, rainmin=1.0e-9 & - &, rainmin=1.0e-8 & - &, oneopt9=1.0/0.09 & - &, oneopt4=1.0/0.04 + &, rainmin=1.0d-8 & + &, oneopt9=one/0.09d0 & + &, oneopt4=one/0.04d0 ! TEMPORARY WORK SPACE @@ -1470,7 +1470,7 @@ SUBROUTINE CLOUD( & hcrit = hcrits else hcrit = (hcrits*(sgcs(kd)-0.5d0) + hcritd*(0.65d0-sgcs(kd))) - & * (1.0d0/0.15d0) + & * (one/0.15d0) endif IF (CALKBL) THEN KTEM = MAX(KD+1, KBLMX) @@ -1556,7 +1556,7 @@ SUBROUTINE CLOUD( & ii = max(kbl,kd1) kbl = max(klcl,kd1) - tem = min(50.0,max(10.0,(prl(kmaxp1)-prl(kd))*0.10)) + tem = min(50.0d0,max(10.0d0,(prl(kmaxp1)-prl(kd))*0.10d0)) if (prl(kmaxp1) - prl(ii) > tem .and. ii > kbl) kbl = ii ! if(lprnt) write(0,*)' kbl2=',kbl,' ii=',ii @@ -1627,8 +1627,8 @@ SUBROUTINE CLOUD( & ZET(KBL) = zero ! shal_fac = one -! if (prl(kbl)-prl(kd) < 300.0 .and. kmax == k) shal_fac = shalfac - if (prl(kbl)-prl(kd) < 350.0 .and. kmax == k) shal_fac = shalfac +! if (prl(kbl)-prl(kd) < 300.0d0 .and. kmax == k) shal_fac = shalfac + if (prl(kbl)-prl(kd) < 350.0d0 .and. kmax == k) shal_fac = shalfac DO L=Kmax,KD,-1 IF (L >= KBL) THEN ETA(L) = (PRL(Kmaxp1)-PRL(L)) * PRISM @@ -1692,7 +1692,7 @@ SUBROUTINE CLOUD( & endif enddo ! - if (lcon == kd .or. kbl <= kd .or. prl(kbl)-prsm(lcon) > 150.0) & + if (lcon == kd .or. kbl <= kd .or. prl(kbl)-prsm(lcon) > 150.0d0) & & return ! TX1 = RHFACS - QBL / TX1 ! Average RH @@ -1709,9 +1709,9 @@ SUBROUTINE CLOUD( & IF (.NOT. cnvflg) RETURN ! - RHC = MAX(ZERO, MIN(ONE, EXP(-20.0*TX1) )) + RHC = MAX(ZERO, MIN(ONE, EXP(-20.0d0*TX1) )) ! - wcbase = 0.1 + wcbase = 0.1d0 if (ntrc > 0) then DO N=1,NTRC RBL(N) = ROI(Kmax,N) * ETA(Kmax) @@ -1724,9 +1724,9 @@ SUBROUTINE CLOUD( & ! ! if (ntk > 0 .and. do_aw) then if (ntk > 0) then - if (rbl(ntk) > 0.0) then - wcbase = min(2.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) -! wcbase = min(1.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) + if (rbl(ntk) > zero) then + wcbase = min(2.0d0, max(wcbase, sqrt(twoo3*rbl(ntk)))) +! wcbase = min(one, max(wcbase, sqrt(twoo3*rbl(ntk)))) endif endif @@ -1799,7 +1799,7 @@ SUBROUTINE CLOUD( & ! endif ! st1 = qil(kd) - st2 = c0i * st1 * exp(c0ifac*min(tol(kd)-t0c,0.0)) + st2 = c0i * st1 * exp(c0ifac*min(tol(kd)-t0c,zero)) tem = c0 * (one-st1) tem2 = st2*qi0 + tem*qw0 ! @@ -1826,7 +1826,7 @@ SUBROUTINE CLOUD( & AKC(L) = one / AKT(L) ! st1 = half * (qil(l)+qil(lp1)) - st2 = c0i * st1 * exp(c0ifac*min(tol(lp1)-t0c,0.0)) + st2 = c0i * st1 * exp(c0ifac*min(tol(lp1)-t0c,zero)) tem = c0 * (one-st1) tem2 = st2*qi0 + tem*qw0 ! @@ -1898,13 +1898,13 @@ SUBROUTINE CLOUD( & HSU = HSU - ALM * TX3 ! CLP = ZERO - ALM = -100.0 + ALM = -100.0d0 HOS = HOL(KD) QOS = QOL(KD) QIS = CIL(KD) QLS = CLL(KD) - cnvflg = HBL > HSU .and. abs(tx1) > 1.0e-4 + cnvflg = HBL > HSU .and. abs(tx1) > 1.0d-4 ! if (lprnt) write(0,*)' ii=',ii,' cnvflg=',cnvflg,' hsu=',hsu ! &,' hbl=',hbl,' tx1=',tx1,' hsd=',hsd @@ -1926,7 +1926,7 @@ SUBROUTINE CLOUD( & ! if (tx2 == zero) then alm = - st2 / tx1 - if (alm > almax) alm = -100.0 + if (alm > almax) alm = -100.0d0 else x00 = tx2 + tx2 epp = tx1 * tx1 - (x00+x00)*st2 @@ -1935,8 +1935,8 @@ SUBROUTINE CLOUD( & tem = sqrt(epp) tem1 = (-tx1-tem)*x00 tem2 = (-tx1+tem)*x00 - if (tem1 > almax) tem1 = -100.0 - if (tem2 > almax) tem2 = -100.0 + if (tem1 > almax) tem1 = -100.0d0 + if (tem2 > almax) tem2 = -100.0d0 alm = max(tem1,tem2) ! if (lprnt) write(0,*) ' tem1=',tem1,' tem2=',tem2,' alm=',alm @@ -2015,12 +2015,12 @@ SUBROUTINE CLOUD( & ACR = zero TEM = PRL(KD1) - (PRL(KD1)-PRL(KD)) * CLP * HALF tx1 = PRL(KBL) - TEM - tx2 = min(900.0, max(tx1,100.0)) - tem1 = log(tx2*0.01) * oneolog10 + tx2 = min(900.0d0, max(tx1,100.0d0)) + tem1 = log(tx2*0.01d0) * oneolog10 tem2 = one - tem1 if ( kdt == 1 ) then -! rel_fac = (dt * facdt) / (tem1*12.0 + tem2*3.0) - rel_fac = (dt * facdt) / (tem1*6.0 + tem2*adjts_s) +! rel_fac = (dt * facdt) / (tem1*12.0d0 + tem2*3.0d0) + rel_fac = (dt * facdt) / (tem1*6.0d0 + tem2*adjts_s) else rel_fac = (dt * facdt) / (tem1*adjts_d + tem2*adjts_s) endif @@ -2241,7 +2241,7 @@ SUBROUTINE CLOUD( & ! CALCUP = .FALSE. - TEM = max(0.05, MIN(CD*200.0, MAX_NEG_BOUY)) + TEM = max(0.05d0, MIN(CD*200.0d0, MAX_NEG_BOUY)) IF (.not. cnvflg .and. WFN > ACR .and. & & dpneg < dpnegcr .and. AKM <= TEM) CALCUP = .TRUE. @@ -2289,7 +2289,7 @@ SUBROUTINE CLOUD( & ENDIF PL = (PRL(KD1) + PRL(KD))*HALF - IF (TRAIN > 1.0E-4 .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. + IF (TRAIN > 1.0d-4 .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. ENDIF ! ! if (lprnt) then @@ -2643,7 +2643,7 @@ SUBROUTINE CLOUD( & ! sigf(kd) = max(zero, min(one, tx1 * tx1)) ! endif if (do_aw) then - tx1 = (0.2 / max(alm, 1.0e-5)) + tx1 = (0.2d0 / max(alm, 1.0d-5)) tx2 = one - min(one, pi * tx1 * tx1 / garea) ! if(lprnt) write(0,*)' kd=',kd,' alm=',alm,' tx1=',tx1 ! &,' garea=',garea,' pi=',pi,' tx2=',tx2 @@ -2795,13 +2795,13 @@ SUBROUTINE CLOUD( & endif enddo tem = tem + amb * dof * sigf(kbl) - tem = tem * (3600.0/dt) + tem = tem * (3600.0d0/dt) !!!! tem1 = max(1.0, min(100.0,sqrt((5.0E10/max(garea,one))))) ! tem1 = max(1.0, min(100.0,(7.5E10/max(garea,one)))) ! tem1 = max(1.0, min(100.0,(5.0E10/max(garea,one)))) ! tem1 = max(1.0, min(100.0,(4.0E10/max(garea,one)))) !! tem1 = sqrt(max(1.0, min(100.0,(4.0E10/max(garea,one))))) ! 20100902 - tem1 = sqrt(max(one, min(100.0,(6.25E10/max(garea,one))))) ! 20110530 + tem1 = sqrt(max(one, min(100.0d0,(6.25d10/max(garea,one))))) ! 20110530 ! if (lprnt) write(0,*)' clfr0=',clf(tem),' tem=',tem,' tem1=', & ! & tem1 @@ -2862,7 +2862,7 @@ SUBROUTINE CLOUD( & tem4 = zero if (tx1 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778 ) ) + & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778d0 ) ) ACTEVAP = MIN(TX1, TEM4*CLFRAC) ! if(lprnt) write(0,*)' L=',L,' actevap=',actevap,' tem4=',tem4, @@ -2873,7 +2873,7 @@ SUBROUTINE CLOUD( & ! tem4 = zero if (tx2 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778 ) ) + & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778d0 ) ) TEM4 = min(MIN(TX2, TEM4*CLDFRD), potevap-actevap) if (tx2 < rainmin*dt) tem4 = min(tx2, potevap-actevap) ! @@ -2946,7 +2946,7 @@ SUBROUTINE CLOUD( & ! following Liu et al. [JGR,2001] Eq 1 if (FSCAV_(N) > zero) then - DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001) + DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001d0) FNOSCAV = exp(- FSCAV_(N) * DELZKM) else FNOSCAV = one @@ -2956,7 +2956,7 @@ SUBROUTINE CLOUD( & & * FNOSCAV DO L=KD1,K if (FSCAV_(N) > zero) then - DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001) + DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001d0) FNOSCAV = exp(- FSCAV_(N) * DELZKM) endif lm1 = l - 1 @@ -3097,7 +3097,7 @@ SUBROUTINE DDRFT( & ! integer, parameter :: NUMTLA=2 ! integer, parameter :: NUMTLA=4 - parameter (ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) + parameter (ERRMIN=0.0001d0, ERRMI2=0.1d0*ERRMIN) ! parameter (ERRMIN=0.00001, ERRMI2=0.1*ERRMIN) ! real (kind=kind_phys), parameter :: PIINV=one/PI @@ -3108,8 +3108,9 @@ SUBROUTINE DDRFT( & ! parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=0.5) ! PARAMETER (AA1=1.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) ! PARAMETER (AA1=2.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) - PARAMETER (AA1=1.0, BB1=1.0, CC1=1.0, DD1=1.0, F3=CC1, F5=1.0) - parameter (QRMIN=1.0E-6, WC2MIN=0.01, GMF1=GMF/AA1, GMF5=GMF/F5) + PARAMETER (AA1=1.0d0, BB1=1.0d0, CC1=1.0d0, DD1=1.0d0, & + & F3=CC1, F5=1.0d0) + parameter (QRMIN=1.0d-6, WC2MIN=0.01d0, GMF1=GMF/AA1, GMF5=GMF/F5) ! parameter (QRMIN=1.0E-6, WC2MIN=1.00, GMF1=GMF/AA1, GMF5=GMF/F5) parameter (WCMIN=sqrt(wc2min)) ! parameter (sialf=0.5) @@ -3146,7 +3147,7 @@ SUBROUTINE DDRFT( & CLDFRD = zero RNTP = zero DOF = zero - ERRQ = 10.0 + ERRQ = 10.0d0 RNB = zero RNT = zero TX2 = PRL(KBL) @@ -3177,7 +3178,7 @@ SUBROUTINE DDRFT( & ENDDO if (kk /= kbl) then do l=kk,kbl - buy(l) = 0.9 * buy(l-1) + buy(l) = 0.9d0 * buy(l-1) enddo endif ! @@ -3185,24 +3186,24 @@ SUBROUTINE DDRFT( & qrpi(l) = buy(l) enddo do l=kd1,kb1 - buy(l) = 0.25 * (qrpi(l-1)+qrpi(l)+qrpi(l)+qrpi(l+1)) + buy(l) = 0.25d0 * (qrpi(l-1)+qrpi(l)+qrpi(l)+qrpi(l+1)) enddo ! ! CALL ANGRAD(TX1, ALM, STLA, CTL2, AL2, PI, TLA, TX2, WFN, TX3) - tx1 = 1000.0 + tx1 - prl(kp1) + tx1 = 1000.0d0 + tx1 - prl(kp1) ! CALL ANGRAD(TX1, ALM, AL2, TLA, TX2, WFN, TX3) CALL ANGRAD(TX1, ALM, AL2, TLA) ! ! Following Ucla approach for rain profile ! - F2 = (BB1+BB1)*ONEBG/(PI*0.2) + F2 = (BB1+BB1)*ONEBG/(PI*0.2d0) ! WCMIN = SQRT(WC2MIN) ! WCBASE = WCMIN ! ! del_tla = TLA * 0.2 ! del_tla = TLA * 0.25 - del_tla = TLA * 0.3 + del_tla = TLA * 0.3d0 TLA = TLA - DEL_TLA ! DO L=KD,K @@ -3263,7 +3264,7 @@ SUBROUTINE DDRFT( & do ntla=1,numtla ! numtla is the the maximimu number of tilting angle tries ! ------ ! if (errq < 1.0 .or. tla > 45.0) cycle - if (errq < 0.1 .or. tla > 45.0) cycle + if (errq < 0.1d0 .or. tla > 45.0d0) cycle ! tla = tla + del_tla STLA = SIN(TLA*deg2rad) ! sine of tilting angle @@ -3273,9 +3274,9 @@ SUBROUTINE DDRFT( & ! &,0.5*(prl(kd)+prl(kd1)),' ntla=',ntla,' f2=',f2,' stla=',stla ! if (lprnt) write(0,*)' buy=',(buy(l),l=kd,kbl) ! - STLA = F2 * STLA * AL2 - CTL2 = DD1 * CTL2 - CTL3 = 0.1364 * CTL2 + STLA = F2 * STLA * AL2 + CTL2 = DD1 * CTL2 + CTL3 = 0.1364d0 * CTL2 ! DO L=KD,K RNF(L) = zero @@ -3351,7 +3352,7 @@ SUBROUTINE DDRFT( & VRW(1) = F3*WVL(KD) - CTL2*VT(1) BUD(KD) = STLA * TX6 * QRB(KD) * half RNF(KD) = BUD(KD) - DOF = 1.1364 * BUD(KD) * QRPI(KD) + DOF = 1.1364d0 * BUD(KD) * QRPI(KD) DOFW = -BUD(KD) * STLT(KD) ! RNT = TRW(1) * VRW(1) @@ -3385,7 +3386,7 @@ SUBROUTINE DDRFT( & ! QA(2) = DOF WA(2) = DOFW - DOF = 1.1364 * BUD(L) * QRPI(L) + DOF = 1.1364d0 * BUD(L) * QRPI(L) DOFW = -BUD(L) * STLT(L) ! RNF(LL) = RNF(LL) + QQQ * ST1 @@ -3456,7 +3457,7 @@ SUBROUTINE DDRFT( & QA(2) = DOF WA(2) = DOFW - DOF = 1.1364 * BUD(L) * QRPI(L) + DOF = 1.1364d0 * BUD(L) * QRPI(L) DOFW = -BUD(L) * STLT(L) ! RNF(LL) = RNF(LL) + ST1 @@ -3597,7 +3598,7 @@ SUBROUTINE DDRFT( & ENDDO ! ! tem = 0.5 - if (tx2 > one .and. abs(errq-tx2) > 0.1) then + if (tx2 > one .and. abs(errq-tx2) > 0.1d0) then tem = half !! elseif (tx2 < 0.1) then !! tem = 1.2 @@ -3625,18 +3626,18 @@ SUBROUTINE DDRFT( & ELSE TEM = ERRQ - TX2 ! IF (TEM < ZERO .AND. ERRQ > 0.1) THEN - IF (TEM < ZERO .AND. ERRQ > 0.5) THEN + IF (TEM < ZERO .AND. ERRQ > 0.5d0) THEN ! IF (TEM < ZERO .and. & ! & (ntla < numtla .or. ERRQ > 0.5)) THEN ! if (lprnt) write(0,*)' tx2=',tx2,' errq=',errq,' tem=',tem SKPUP = .TRUE. ! No convergence ! - ERRQ = 10.0 ! No rain profile! + ERRQ = 10.0d0 ! No rain profile! !!!! ELSEIF (ABS(TEM) < ERRMI2 .OR. TX2 < ERRMIN) THEN ELSEIF (TX2 < ERRMIN) THEN SKPUP = .TRUE. ! Converges ! ERRQ = zero ! Rain profile exists! ! if (lprnt) write(0,*)' here2' - elseif (tem < zero .and. errq < 0.1) then + elseif (tem < zero .and. errq < 0.1d0) then skpup = .true. ! if (ntla == numtla .or. tem > -0.003) then errq = zero @@ -3663,7 +3664,7 @@ SUBROUTINE DDRFT( & ! &,' errq=',errq ! endif ! - IF (ERRQ < 0.1) THEN + IF (ERRQ < 0.1d0) THEN DDFT = .TRUE. RNB = - RNB ! do l=kd1,kb1-1 @@ -3686,7 +3687,7 @@ SUBROUTINE DDRFT( & ! if (lprnt) write(0,*)' tx1+rnt+rnb=',tx1+rnt+rnb, ' train=',train TX1 = TRAIN / (TX1+RNT+RNB) ! if (lprnt) write(0,*)' tx1= ', tx1 - IF (ABS(TX1-one) < 0.2) THEN + IF (ABS(TX1-one) < 0.2d0) THEN RNT = MAX(RNT*TX1,ZERO) RNB = RNB * TX1 DO L=KD,KB1 @@ -3699,7 +3700,7 @@ SUBROUTINE DDRFT( & ELSE DDFT = .FALSE. - ERRQ = 10.0 + ERRQ = 10.0d0 ENDIF ENDIF ! @@ -3724,7 +3725,7 @@ SUBROUTINE DDRFT( & WCB(L) = zero ENDDO ! - ERRQ = 10.0 + ERRQ = 10.0d0 ! At this point stlt contains inverse of updraft vertical velocity 1/Wu. KK = MAX(KB1,KD1) @@ -3774,9 +3775,9 @@ SUBROUTINE DDRFT( & IF (RNT > zero) THEN if (TX1 > zero) THEN QRP(KD) = (RPART*RNT / (ROR(KD)*TX1*GMS(KD))) & - & ** (one/1.1364) + & ** (one/1.1364d0) else - tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364) + tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364d0) endif RNTP = (one - RPART) * RNT BUY(KD) = - ROR(KD) * TX1 * QRP(KD) @@ -3840,7 +3841,7 @@ SUBROUTINE DDRFT( & VRW(1) = half * (GAM(L-1) + GAM(L)) VRW(2) = one / (VRW(1) + VRW(1)) ! - TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.00*EKNOB) + TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.0d0*EKNOB) ! DOFW = one / (WA(3) * (one + NU*WA(2))) ! 1.0 / TVbar! ! @@ -3848,7 +3849,7 @@ SUBROUTINE DDRFT( & HOD(L) = HOD(L-1) QOD(L) = QOD(L-1) ! - ERRQ = 10.0 + ERRQ = 10.0d0 ! IF (L <= KBL) THEN @@ -3873,7 +3874,7 @@ SUBROUTINE DDRFT( & IF (L == KD1) THEN IF (RNT > zero) THEN TEM = MAX(QRP(L-1),QRP(L)) - WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0) + WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0d0) ENDIF WVL(L) = MAX(ONE_M2, WVL(L)) TRW(1) = TRW(1) * half @@ -4019,9 +4020,9 @@ SUBROUTINE DDRFT( & ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) TEM2 = ROR(L) * QRP(L) CALL QRABF(TEM2,QRAF,QRBF) - TEM6 = TX5 * (1.6 + 124.9 * QRAF) * QRBF * TX4 + TEM6 = TX5 * (1.6d0 + 124.9d0 * QRAF) * QRBF * TX4 ! - CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6 * ST2 / ((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) ! TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) TEM3 = (one + TEM1) * QHS * (QOD(L)+CE) @@ -4032,7 +4033,7 @@ SUBROUTINE DDRFT( & ! second iteration ! ! ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6 * ST2 / ((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) ! CEE = CE * (ETD(L)+DDZ) ! @@ -4056,7 +4057,7 @@ SUBROUTINE DDRFT( & QRP(L) = MAX(TEM,ZERO) ELSEIF (TX5 > zero) THEN QRP(L) = (MAX(ZERO,QA(1)/(ROR(L)*TX5*GMS(L)))) & - & ** (one/1.1364) + & ** (one/1.1364d0) ELSE QRP(L) = zero ENDIF @@ -4092,7 +4093,7 @@ SUBROUTINE DDRFT( & ! WVL(L) = 0.5*tem1 ! WVL(L) = 0.1*tem1 ! WVL(L) = 0.0 - WVL(L) = 1.0e-10 + WVL(L) = 1.0d-10 else WVL(L) = half*(WVL(L)+TEM1) endif @@ -4116,7 +4117,7 @@ SUBROUTINE DDRFT( & ! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN ! if(lprnt) write(0,*)' itr=',itr,' etd1=',etd(l-1),' errq=',errq - IF (ETD(L-1) == zero .AND. ERRQ > 0.2) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.2d0) THEN ! if(lprnt) write(0,*)' bud=',bud(kd),' wa=',wa(1),wa(2) ROR(L) = BUD(KD) ETD(L) = zero @@ -4129,7 +4130,7 @@ SUBROUTINE DDRFT( & TX5 = TX9 else TX5 = (STLT(KB1) * QRT(KB1) & - & + STLT(KBL) * QRB(KB1)) * (0.5*FAC) + & + STLT(KBL) * QRB(KB1)) * (0.5d0*FAC) endif ! if(lprnt) write(0,*)' tx1=',tx1,' rnt=',rnt,' rnf=',rnf(l-1) @@ -4151,14 +4152,14 @@ SUBROUTINE DDRFT( & ! *,' errq=',errq QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (one/1.1364) + & ** (one/1.1364d0) ! endif BUY(L) = - ROR(L) * TX5 * QRP(L) WCB(L-1) = zero ENDIF ! DEL_ETA = ETD(L) - ETD(L-1) - IF(DEL_ETA < zero .AND. ERRQ > 0.1) THEN + IF(DEL_ETA < zero .AND. ERRQ > 0.1d0) THEN ROR(L) = BUD(KD) ETD(L) = zero WVL(L) = zero @@ -4185,9 +4186,9 @@ SUBROUTINE DDRFT( & ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) TEM2 = ROR(L) * QRP(L-1) CALL QRABF(TEM2,QRAF,QRBF) - TEM6 = TX5 * (1.6 + 124.9 * QRAF) * QRBF * TX4 + TEM6 = TX5 * (1.6d0 + 124.9d0 * QRAF) * QRBF * TX4 ! - CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6*ST2/((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) ! TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) @@ -4198,7 +4199,7 @@ SUBROUTINE DDRFT( & ! second iteration ! ! ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6*ST2/((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) ! CEE = CE * (ETD(L)+DDZ) ! @@ -4258,7 +4259,8 @@ SUBROUTINE DDRFT( & ! ENDDO ! End of the iteration loop for a given L! IF (L <= K) THEN - IF (ETD(L-1) == zero .AND. ERRQ > 0.1 .and. l <= kbl) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.1d0 .and. & + & l <= kbl) THEN !!! & .AND. ERRQ > ERRMIN*10.0 .and. l <= kbl) THEN ! & .AND. ERRQ > ERRMIN*10.0) THEN ROR(L) = BUD(KD) @@ -4281,7 +4283,7 @@ SUBROUTINE DDRFT( & ! IF (QA(1) > 0.0) THEN QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (one/1.1364) + & ** (one/1.1364d0) ! ENDIF ETD(L) = zero WVL(L) = zero @@ -4318,7 +4320,7 @@ SUBROUTINE DDRFT( & ! not converge) , no downdraft is assumed ! ! IF (ERRQ > ERRMIN*100.0 .AND. IDN(idnm) == 99) & - IF (ERRQ > 0.1 .AND. IDN(idnm) == idnmax) DDFT = .FALSE. + IF (ERRQ > 0.1d0 .AND. IDN(idnm) == idnmax) DDFT = .FALSE. ! DOF = zero IF (.NOT. DDFT) RETURN @@ -4423,18 +4425,18 @@ SUBROUTINE QSATCN(TT,P,Q,DQDT) ! real(kind=kind_phys) TT, P, Q, DQDT ! - real(kind=kind_phys), parameter :: ZERO=0.0, ONE=1.0 & - &, ONE_M10=1.E-10 & + real(kind=kind_phys), parameter :: ZERO=0.0d0, ONE=1.0d0 & + &, ONE_M10=1.0d-10 & &, rvi=one/rv, facw=CVAP-CLIQ & &, faci=CVAP-CSOL, hsub=HVAP+HFUS & - &, tmix=TTP-20.0 & + &, tmix=TTP-20.0d0 & &, DEN=one/(TTP-TMIX) ! logical lprnt ! real(kind=kind_phys) es, d, hlorv, W ! -! es = 10.0 * fpvs(tt) ! fpvs is in centibars! - es = min(p, 0.01 * fpvs(tt)) ! fpvs is in Pascals! +! es = 10.0 * fpvs(tt) ! fpvs is in centibars! + es = min(p, 0.01d0 * fpvs(tt)) ! fpvs is in Pascals! ! D = one / max(p+epsm1*es,ONE_M10) D = one / (p+epsm1*es) ! @@ -4457,7 +4459,7 @@ SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) ! integer i ! - IF (TLA < 0.0) THEN + IF (TLA < 0.0d0) THEN IF (PRES <= PLAC(1)) THEN TLA = TLAC(1) ELSEIF (PRES <= PLAC(2)) THEN @@ -4494,8 +4496,8 @@ SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) TEM = REFR(6) ENDIF ! - tem = 2.0E-4 / tem - al2 = min(4.0*tem, max(alm, tem)) + tem = 2.0d-4 / tem + al2 = min(4.0d0*tem, max(alm, tem)) ! RETURN END @@ -4508,18 +4510,18 @@ SUBROUTINE SETQRP integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! XMIN = 1.0E-6 - XMIN = 0.0 - XMAX = 5.0 + XMIN = 0.0d0 + XMAX = 5.0d0 XINC = (XMAX-XMIN)/(NQRP-1) C2XQRP = one / XINC C1XQRP = one - XMIN*C2XQRP - TEM1 = 0.001 ** 0.2046 - TEM2 = 0.001 ** 0.525 + TEM1 = 0.001d0 ** 0.2046d0 + TEM2 = 0.001d0 ** 0.525d0 DO JX=1,NQRP X = XMIN + (JX-1)*XINC - TBQRP(JX) = X ** 0.1364 - TBQRA(JX) = TEM1 * X ** 0.2046 - TBQRB(JX) = TEM2 * X ** 0.525 + TBQRP(JX) = X ** 0.1364d0 + TBQRA(JX) = TEM1 * X ** 0.2046d0 + TBQRB(JX) = TEM2 * X ** 0.525d0 ENDDO ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN @@ -4566,8 +4568,8 @@ SUBROUTINE SETVTP real(kind=kind_phys) xinc,x,xmax,xmin integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN = 0.05 - XMAX = 1.5 + XMIN = 0.05d0 + XMAX = 1.5d0 XINC = (XMAX-XMIN)/(NVTP-1) C2XVTP = one / XINC C1XVTP = one - XMIN*C2XVTP @@ -4599,10 +4601,10 @@ FUNCTION CLF(PRATE) implicit none real(kind=kind_phys) PRATE, CLF ! - real (kind=kind_phys), parameter :: ccf1=0.30, ccf2=0.09 & - &, ccf3=0.04, ccf4=0.01 & - &, pr1=1.0, pr2=5.0 & - &, pr3=20.0 + real (kind=kind_phys), parameter :: ccf1=0.30d0, ccf2=0.09d0 & + &, ccf3=0.04d0, ccf4=0.01d0 & + &, pr1=1.0d0, pr2=5.0d0 & + &, pr3=20.0d0 ! if (prate < pr1) then clf = ccf1 diff --git a/gfsphysics/physics/sfc_drv.f b/gfsphysics/physics/sfc_drv.f index bd1ad4f5f..7f3a104b4 100644 --- a/gfsphysics/physics/sfc_drv.f +++ b/gfsphysics/physics/sfc_drv.f @@ -170,15 +170,15 @@ subroutine sfc_drv & real(kind=kind_phys), parameter :: cpinv = one/cp real(kind=kind_phys), parameter :: hvapi = one/hvap real(kind=kind_phys), parameter :: elocp = hvap/cp - real(kind=kind_phys), parameter :: rhoh2o = 1000.0 - real(kind=kind_phys), parameter :: a2 = 17.2693882 - real(kind=kind_phys), parameter :: a3 = 273.16 - real(kind=kind_phys), parameter :: a4 = 35.86 + real(kind=kind_phys), parameter :: rhoh2o = 1000.0d0 + real(kind=kind_phys), parameter :: a2 = 17.2693882d0 + real(kind=kind_phys), parameter :: a3 = 273.16d0 + real(kind=kind_phys), parameter :: a4 = 35.86d0 real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) real(kind=kind_phys), parameter :: qmin = 1.0d-8 real(kind=kind_phys), save :: zsoil_noah(4) - data zsoil_noah / -0.1, -0.4, -1.0, -2.0 / + data zsoil_noah / -0.1d0, -0.4d0, -1.0d0, -2.0d0 / ! --- input: integer, intent(in) :: im, km, isot, ivegsrc diff --git a/gfsphysics/physics/sfc_ocean.f b/gfsphysics/physics/sfc_ocean.f index a1cf2c902..ad18899fc 100644 --- a/gfsphysics/physics/sfc_ocean.f +++ b/gfsphysics/physics/sfc_ocean.f @@ -67,17 +67,14 @@ subroutine sfc_ocean & ! use machine , only : kind_phys use funcphys, only : fpvs - use physcons, only : cp => con_cp, rd => con_rd, eps => con_eps, & - & epsm1 => con_epsm1, hvap => con_hvap, & - & rvrdm1 => con_fvirt + use physcons, only : rd => con_rd, eps => con_eps, & + & epsm1 => con_epsm1, rvrdm1 => con_fvirt ! implicit none ! ! --- constant parameters: - real (kind=kind_phys), parameter :: one = 1.0d0, zero = 0.0d0 & - &, cpinv = one/cp & - &, hvapi = one/hvap & - &, elocp = hvap/cp, qmin = 1.0d-8 + real (kind=kind_phys), parameter :: one = 1.0d0, zero = 0.0d0 & + &, qmin = 1.0d-8 ! --- inputs: integer, intent(in) :: im @@ -94,22 +91,18 @@ subroutine sfc_ocean & ! --- locals: real (kind=kind_phys) :: q0, qss, rho, tem - - integer :: i - - logical :: flag(im) + integer :: i ! !===> ... begin here ! -! --- ... flag for open water do i = 1, im - flag(i) = (wet(i) .and. flag_iter(i)) ! --- ... initialize variables. all units are supposedly m.k.s. unless specified ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface - if ( flag(i) ) then + if (wet(i) .and. flag_iter(i)) then + q0 = max(q1(i), qmin) rho = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0)) From a2b883ba986a0fef40e93c2ea11ea19b9265d6f0 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 18 Apr 2020 23:56:27 +0000 Subject: [PATCH 37/91] some bug fix in ras and mg3 and make constants douple precision --- ccpp/framework | 2 +- gfsphysics/physics/gcm_shoc.f90 | 6 ++-- gfsphysics/physics/m_micro_driver.F90 | 44 +++++++++++++-------------- gfsphysics/physics/micro_mg_utils.F90 | 8 ++--- gfsphysics/physics/moninshoc.f | 4 +-- gfsphysics/physics/rascnvv2.f | 2 +- gfsphysics/physics/sfc_diff.f | 8 ++--- gfsphysics/physics/sfc_drv.f | 4 +-- gfsphysics/physics/sfc_sice.f | 10 +++--- 9 files changed, 44 insertions(+), 44 deletions(-) diff --git a/ccpp/framework b/ccpp/framework index d32b965b1..4b9cd89b4 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit d32b965b11882a42d9db522dc13823b7720b63aa +Subproject commit 4b9cd89b4fbbd9dfbee98af3491d5fc0e55bbadf diff --git a/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 index fa6133899..6916dd96a 100644 --- a/gfsphysics/physics/gcm_shoc.f90 +++ b/gfsphysics/physics/gcm_shoc.f90 @@ -968,7 +968,7 @@ subroutine check_eddy() do i=1,nx - wrk = 0.1*adzl(i,k) + wrk = 0.1d0*adzl(i,k) ! Minimum 0.1 of local dz smixt(i,k) = max(wrk, min(max_eddy_length_scale,smixt(i,k))) @@ -1249,7 +1249,7 @@ subroutine assumed_pdf() ELSE !aab @@ -1574,7 +1574,6 @@ subroutine assumed_pdf() ! ,' hl=',hl(i,k),' gamaz=',gamaz(i,k),' diag_ql=',diag_ql,' qpl=',qpl(i,k)& ! ,' diag_qi=',diag_qi,' qpi=',qpi(i,k),' diag_qn =',diag_qn ,' aterm=',aterm,' onema=',onema& ! ,' qn1=',qn1 ,' qn2=',qn2,' ql1=',ql1,' ql2=',ql2 -! Update moisture fields ! Update ncpl and ncpi Anning Cheng 03/11/2016 ! ncpl(i,k) = diag_ql/max(qc(i,k),1.e-10)*ncpl(i,k) @@ -1593,6 +1592,7 @@ subroutine assumed_pdf() endif endif +! Update moisture fields qc(i,k) = diag_ql qi(i,k) = diag_qi qwv(i,k) = max(zero, total_water(i,k) - diag_qn) diff --git a/gfsphysics/physics/m_micro_driver.F90 b/gfsphysics/physics/m_micro_driver.F90 index 07979a810..87e88046a 100644 --- a/gfsphysics/physics/m_micro_driver.F90 +++ b/gfsphysics/physics/m_micro_driver.F90 @@ -312,7 +312,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & DO K=0, LM ll = lm-k DO I = 1,IM - PLE(i,k) = prsi_i(i,ll) *0.01d0 ! interface pressure in hPa + PLE(i,k) = prsi_i(i,ll) * 0.01d0 ! interface pressure in hPa zet(i,k+1) = phii(i,ll) * onebg END DO END DO @@ -526,11 +526,11 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do L=LM,1,-1 do i=1,im blk_l(i,l) = one / (one/max(0.15d0*ZPBL(i),0.4d0*zlo(i,lm-1))& - & + one/(zlo(i,l)*.4d0) ) + & + one/(zlo(i,l)*0.4d0) ) SC_ICE(i,l) = one - NCPL(i,l) = MAX( NCPL(i,l), 0.0d0) - NCPI(i,l) = MAX( NCPI(i,l), 0.0d0) + NCPL(i,l) = MAX( NCPL(i,l), zero) + NCPI(i,l) = MAX( NCPI(i,l), zero) RAD_CF(i,l) = max(zero, min(CLLS(i,l)+CLCN(i,l), one)) if (.not. iccn) then CDNC_NUC(i,l) = zero @@ -647,7 +647,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! rad_cooling(k) = RADheat(I,k) if (npre8(k) > zero .and. qir8(k) > zero) then - dpre8(k) = ( qir8(k)/(6.0*npre8(k)*900.0d0*PI))**(one/3.0d0) + dpre8(k) = ( qir8(k)/(6.0d0*npre8(k)*900.0d0*PI))**(one/3.0d0) else dpre8(k) = 1.0d-9 endif @@ -813,7 +813,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & smaxicer8(K) = zero nheticer8(K) = zero sc_icer8(K) = 2.0d0 -! sc_icer8(K) = 1.0 +! sc_icer8(K) = 1.0d0 naair8(K) = zero npccninr8(K) = zero nlimicer8(K) = zero @@ -840,13 +840,13 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! if(temp(i,k) < T_ICE_ALL) then ! SC_ICE(i,k) = max(SC_ICE(I,k), 1.2) - SC_ICE(i,k) = max(SC_ICE(I,k), 1.5) + SC_ICE(i,k) = max(SC_ICE(I,k), 1.5d0) elseif(temp(i,k) > TICE) then SC_ICE(i,k) = rhc(i,k) else ! SC_ICE(i,k) = 1.0 ! tx1 = max(SC_ICE(I,k), 1.2) - tx1 = max(SC_ICE(I,k), 1.5) + tx1 = max(SC_ICE(I,k), 1.5d0) SC_ICE(i,k) = ((tice-temp(i,k))*tx1 + (temp(i,k)-t_ice_all)*rhc(i,k)) & * t_ice_denom endif @@ -1272,7 +1272,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0), 150.0d0) CLDREFFI(I,k) = min(max(effir8(k), 20.0d0), 150.0d0) - CLDREFFR(I,k) = max(droutr8(k)*0.5*1.0d6, 150.0d0) + CLDREFFR(I,k) = max(droutr8(k)*0.5d0*1.0d6, 150.0d0) CLDREFFS(I,k) = max(0.192d0*dsoutr8(k)*0.5d0*1.0d6, 250.0d0) enddo ! K loop @@ -1355,8 +1355,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, aero_in, & & lev_sed_strt) ! - LS_PRC2(I) = max(1000.d0*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.d0*precir8(1), zero) + LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0d0*precir8(1), zero) do k=1,lm QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 @@ -1371,7 +1371,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, zero) CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0),150.0d0) - CLDREFFI(I,k) = min(max(effir8(k), 20.0d0),1500.0d0) + CLDREFFI(I,k) = min(max(effir8(k), 20.0d0),150.0d0) CLDREFFR(I,k) = max(reff_rain(k),150.0d0) CLDREFFS(I,k) = max(reff_snow(k),250.0d0) enddo ! K loop @@ -1491,8 +1491,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, aero_in, & & lev_sed_strt) - LS_PRC2(I) = max(1000.d0*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.d0*precir8(1), zero) + LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0d0*precir8(1), zero) do k=1,lm QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 @@ -1523,8 +1523,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & LS_PRC2(I) = zero LS_SNR(I) = zero do k=1,lm - CLDREFFL(I,k) = 100.0d0 - CLDREFFI(I,k) = 500.0d0 + CLDREFFL(I,k) = 10.0d0 + CLDREFFI(I,k) = 50.0d0 CLDREFFR(I,k) = 1000.0d0 CLDREFFS(I,k) = 250.0d0 CLDREFFG(I,k) = 250.0d0 @@ -1766,7 +1766,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & real(kind=kind_phys), intent(out) :: nm(pcols,pver) real(kind=kind_phys), parameter :: r=rgas, cpair=cp, g=grav, & - oneocp=1.0/cp, n2min=1.e-8 + oneocp=1.0d0/cp, n2min=1.0d-8 !---------------------------Local storage------------------------------- integer :: ix,kx @@ -1782,15 +1782,15 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & kx = 0 do ix = 1, ncol ti(ix,kx) = t(ix,kx+1) - rhoi(ix,kx) = pi(ix,kx) / (r*(ti(ix,kx)*(1.0+fv*sph(ix,kx+1)))) + rhoi(ix,kx) = pi(ix,kx) / (r*(ti(ix,kx)*(1.0d0+fv*sph(ix,kx+1)))) ni(ix,kx) = sqrt (g*g / (cpair*ti(ix,kx))) end do ! Interior points use centered differences do kx = 1, pver-1 do ix = 1, ncol - ti(ix,kx) = 0.5 * (t(ix,kx) + t(ix,kx+1)) - rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0+0.5*fv*(sph(ix,kx)+sph(ix,kx+1)))) + ti(ix,kx) = 0.5d0 * (t(ix,kx) + t(ix,kx+1)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0d0+0.5d0*fv*(sph(ix,kx)+sph(ix,kx+1)))) dtdp = (t(ix,kx+1)-t(ix,kx)) / (pm(ix,kx+1)-pm(ix,kx)) n2 = g*g/ti(ix,kx) * (oneocp - rhoi(ix,kx)*dtdp) ni(ix,kx) = sqrt (max (n2min, n2)) @@ -1802,7 +1802,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & kx = pver do ix = 1, ncol ti(ix,kx) = t(ix,kx) - rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0+fv*sph(ix,kx))) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0d0+fv*sph(ix,kx))) ni(ix,kx) = ni(ix,kx-1) end do @@ -1811,7 +1811,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & !----------------------------------------------------------------------------- do kx=1,pver do ix=1,ncol - nm(ix,kx) = 0.5 * (ni(ix,kx-1) + ni(ix,kx)) + nm(ix,kx) = 0.5d0 * (ni(ix,kx-1) + ni(ix,kx)) end do end do diff --git a/gfsphysics/physics/micro_mg_utils.F90 b/gfsphysics/physics/micro_mg_utils.F90 index 53518bef7..ffd13c2d5 100644 --- a/gfsphysics/physics/micro_mg_utils.F90 +++ b/gfsphysics/physics/micro_mg_utils.F90 @@ -488,7 +488,7 @@ elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc xs = max(min(xs, 1.7_r8), 1.1_r8) xs = xs*xs*xs - xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.)/8.0_r8 + xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.0_r8)/8.0_r8 pgam = sqrt(xs) else @@ -705,8 +705,8 @@ elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) lam = (props%shape_coef * nic/qic)**(1._r8/props%eff_dim) if (ice_sep) then miu_ice = max(min(0.008_r8*(lam*0.01)**0.87_r8, 10.0_r8), 0.1_r8) - tx1 = 1. + miu_ice - tx2 = 1. / gamma(tx1) + tx1 = 1.0_r8 + miu_ice + tx2 = 1.0_r8 / gamma(tx1) aux = (gamma(tx1+3.0_r8)*tx2) ** (1.0_r8/3.0_r8) lam = lam*aux else @@ -1101,7 +1101,7 @@ subroutine liu_liq_autoconversion(pgam,qc,nc,qr,rho,relvar, & beta6 = (one+three*xs)*(one+four*xs)*(one+five*xs) & / ((one+xs)*(one+xs+xs)) LW = 1.0e-3_r8 * qc(i) * rho(i) - NW = nc(i) * rho(i) * 1.e-6_r8 + NW = nc(i) * rho(i) * 1.e-6_r8 xs = min(20.0_r8, 1.03e16_r8*(LW*LW)/(NW*SQRT(NW))) au(i) = 1.1e10_r8*beta6*LW*LW*LW & diff --git a/gfsphysics/physics/moninshoc.f b/gfsphysics/physics/moninshoc.f index 20a2adccc..c0926631a 100644 --- a/gfsphysics/physics/moninshoc.f +++ b/gfsphysics/physics/moninshoc.f @@ -347,7 +347,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! compute tridiagonal matrix elements for heat and moisture ! do i=1,im - ad(i,1) = 1. + ad(i,1) = one a1(i,1) = t1(i,1) + beta(i) * heat(i) a2(i,1) = q1(i,1,1) + beta(i) * evap(i) enddo @@ -381,7 +381,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, al(i,k) = -dtodsu*dsdz2 ! ad(i,k) = ad(i,k)-au(i,k) - ad(i,kp1) = 1.-al(i,k) + ad(i,kp1) = one - al(i,k) dsdzt = tem1 * gocp a1(i,k) = a1(i,k) + dtodsd*dsdzt a1(i,kp1) = t1(i,kp1) - dtodsu*dsdzt diff --git a/gfsphysics/physics/rascnvv2.f b/gfsphysics/physics/rascnvv2.f index 413a1b553..2a17b8ca5 100644 --- a/gfsphysics/physics/rascnvv2.f +++ b/gfsphysics/physics/rascnvv2.f @@ -1725,7 +1725,7 @@ SUBROUTINE CLOUD( & ! if (ntk > 0 .and. do_aw) then if (ntk > 0) then if (rbl(ntk) > zero) then - wcbase = min(2.0d0, max(wcbase, sqrt(twoo3*rbl(ntk)))) + wcbase = min(two, max(wcbase, sqrt(twoo3*rbl(ntk)))) ! wcbase = min(one, max(wcbase, sqrt(twoo3*rbl(ntk)))) endif endif diff --git a/gfsphysics/physics/sfc_diff.f b/gfsphysics/physics/sfc_diff.f index a1dc3e8af..c59a9b851 100644 --- a/gfsphysics/physics/sfc_diff.f +++ b/gfsphysics/physics/sfc_diff.f @@ -2,7 +2,7 @@ module module_sfc_diff use machine , only : kind_phys use physcons, grav => con_g - real (kind=kind_phys), parameter :: ca=.4 ! ca - von karman constant + real (kind=kind_phys), parameter :: ca=0.4d0 ! ca - von karman constant contains subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) @@ -86,7 +86,7 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) do i=1,im if(flag_iter(i)) then - virtfac = 1.0 + rvrdm1 * max(q1(i),qmin) + virtfac = one + rvrdm1 * max(q1(i),qmin) thv1 = t1(i) * prslki(i) * virtfac ! compute stability dependent exchange coefficients @@ -150,7 +150,7 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) ! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land if (ztpert(i) /= zero) then - ztmax = ztmax * (10.d0**ztpert(i)) + ztmax = ztmax * (10.0d0**ztpert(i)) endif ztmax = max(ztmax, zmin) ! @@ -297,7 +297,7 @@ subroutine stability ! --- locals: real(kind=kind_phys), parameter :: alpha=5.0d0, a0=-3.975d0 & - &, a1=12.32d0, alpha4=4.0d0*alpha + &, a1=12.32d0, alpha4=4.0d0*alpha & &, b1=-7.755d0, b2=6.041d0, alpha2=alpha+alpha & &, beta=1.0d0 & &, a0p=-7.941d0, a1p=24.75d0, b1p=-8.705d0, b2p=7.899d0& diff --git a/gfsphysics/physics/sfc_drv.f b/gfsphysics/physics/sfc_drv.f index 7f3a104b4..84b4b84d5 100644 --- a/gfsphysics/physics/sfc_drv.f +++ b/gfsphysics/physics/sfc_drv.f @@ -175,7 +175,7 @@ subroutine sfc_drv & real(kind=kind_phys), parameter :: a3 = 273.16d0 real(kind=kind_phys), parameter :: a4 = 35.86d0 real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) - real(kind=kind_phys), parameter :: qmin = 1.0d-8 + real(kind=kind_phys), parameter :: qmin = 1.0d-8 real(kind=kind_phys), save :: zsoil_noah(4) data zsoil_noah / -0.1d0, -0.4d0, -1.0d0, -2.0d0 / @@ -510,7 +510,7 @@ subroutine sfc_drv & sncovr1(i) = sncovr ! ---- ... outside sflx, roughness uses cm as unit (update after snow's ! effect) - zorl(i) = z0*100.d0 + zorl(i) = z0*100.0d0 ! --- ... do not return the following output fields to parent model ! ec - canopy water evaporation (m s-1) diff --git a/gfsphysics/physics/sfc_sice.f b/gfsphysics/physics/sfc_sice.f index bf5dbbaf3..edb8034fe 100644 --- a/gfsphysics/physics/sfc_sice.f +++ b/gfsphysics/physics/sfc_sice.f @@ -191,7 +191,7 @@ subroutine sfc_sice & if (flag(i)) then if (srflag(i) > zero) then ep(i) = ep(i)*(one-srflag(i)) - weasd(i) = weasd(i) + 1.e3*tprcp(i)*srflag(i) + weasd(i) = weasd(i) + 1.0d3*tprcp(i)*srflag(i) tprcp(i) = tprcp(i)*(one-srflag(i)) endif endif @@ -449,7 +449,7 @@ subroutine ice3lay real (kind=kind_phys), parameter :: didw = di/dw real (kind=kind_phys), parameter :: dsdi = ds/di real (kind=kind_phys), parameter :: ci = 2054.0d0 ! heat capacity of fresh ice (j/kg/k) - real (kind=kind_phys), parameter :: li = 3.34e5 ! latent heat of fusion (j/kg-ice) + real (kind=kind_phys), parameter :: li = 3.34d5 ! latent heat of fusion (j/kg-ice) real (kind=kind_phys), parameter :: si = 1.0d0 ! salinity of sea ice real (kind=kind_phys), parameter :: mu = 0.054d0 ! relates freezing temp to salinity real (kind=kind_phys), parameter :: tfi = -mu*si ! sea ice freezing temp = -mu*salinity @@ -492,9 +492,9 @@ subroutine ice3lay ! !===> ... begin here ! - dt2 = 2.0d0 * delt - dt4 = 4.0d0 * delt - dt6 = 6.0d0 * delt + dt2 = delt + delt + dt4 = dt2 + dt2 + dt6 = dt2 + dt4 dt2i = one / dt2 do i = 1, im From a729847e6f3c253befa9a3c81cc26ec9c5b50f11 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 22 Apr 2020 17:55:19 +0000 Subject: [PATCH 38/91] adding OMP directives to some loops plus using _kind_phys in atmos_model.F90 --- atmos_model.F90 | 30 +++++++++++++++++++----------- ccpp/physics | 2 +- 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index e97935fe7..b978c2a71 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -895,7 +895,7 @@ subroutine update_atmos_model_state (Atmos) if (mpp_pe() == mpp_root_pe()) write(6,*) ' gfs diags time since last bucket empty: ',time_int/3600.,'hrs' call atmosphere_nggps_diag(Atmos%Time) call FV3GFS_diag_output(Atmos%Time, IPD_DIag, Atm_block, IPD_Control%nx, IPD_Control%ny, & - IPD_Control%levs, 1, 1, 1.d0, time_int, time_intfull, & + IPD_Control%levs, 1, 1, 1.0_kind_phys, time_int, time_intfull, & IPD_Control%fhswr, IPD_Control%fhlwr) if (nint(IPD_Control%fhzero) > 0) then if (mod(isec,3600*nint(IPD_Control%fhzero)) == 0) diag_time = Atmos%Time @@ -1191,6 +1191,9 @@ subroutine update_atmos_chemistry(state, rc) ntb = size(IPD_Data(1)%IntDiag%duem, dim=2) nte = size(qu, dim=3) do it = 1, min(ntb, nte) +!$OMP parallel do default (none) & +!$OMP shared (it, nj, ni, Atm_block, IPD_Data, qu) & +!$OMP private (j, jb, i, ib, nb, ix) do j = 1, nj jb = j + Atm_block%jsc - 1 do i = 1, ni @@ -1203,17 +1206,22 @@ subroutine update_atmos_chemistry(state, rc) enddo nte = nte - ntb - do it = 1, min(size(IPD_Data(1)%IntDiag%ssem, dim=2), nte) - do j = 1, nj - jb = j + Atm_block%jsc - 1 - do i = 1, ni - ib = i + Atm_block%isc - 1 - nb = Atm_block%blkno(ib,jb) - ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%IntDiag%ssem(ix,it) = qu(i,j,it+ntb) + if (nte > 0) then + do it = 1, min(size(IPD_Data(1)%IntDiag%ssem, dim=2), nte) +!$OMP parallel do default (none) & +!$OMP shared (it, nj, ni, ntb, Atm_block, IPD_Data, qu) & +!$OMP private (j, jb, i, ib, nb, ix) + do j = 1, nj + jb = j + Atm_block%jsc - 1 + do i = 1, ni + ib = i + Atm_block%isc - 1 + nb = Atm_block%blkno(ib,jb) + ix = Atm_block%ixp(ib,jb) + IPD_Data(nb)%IntDiag%ssem(ix,it) = qu(i,j,it+ntb) + enddo enddo enddo - enddo + endif !--- (c) sedimentation and dry/wet deposition do it = 1, size(qd, dim=3) @@ -1678,7 +1686,7 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - tem = 100.0 * max(zero, min(0.1, datar8(i,j))) + tem = 100.0_kind_phys * max(zero, min(0.1_kind_phys, datar8(i,j))) IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem IPD_Data(nb)%Sfcprop%zorlo(ix) = tem diff --git a/ccpp/physics b/ccpp/physics index f1c24fbd5..e19953d0d 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit f1c24fbd54d66fa78bb776d3770cd97b5dd2ba89 +Subproject commit e19953d0da2ccd4b65bc4ac68a2cc09807805474 From dd978481add70c862474c250c4e4740906e3c2f6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 23 Apr 2020 01:50:28 +0000 Subject: [PATCH 39/91] changing _kind_phys to ipd_kind_phys --- atmos_model.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index b978c2a71..05856e067 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -895,7 +895,7 @@ subroutine update_atmos_model_state (Atmos) if (mpp_pe() == mpp_root_pe()) write(6,*) ' gfs diags time since last bucket empty: ',time_int/3600.,'hrs' call atmosphere_nggps_diag(Atmos%Time) call FV3GFS_diag_output(Atmos%Time, IPD_DIag, Atm_block, IPD_Control%nx, IPD_Control%ny, & - IPD_Control%levs, 1, 1, 1.0_kind_phys, time_int, time_intfull, & + IPD_Control%levs, 1, 1, 1.0_IPD_kind_phys, time_int, time_intfull, & IPD_Control%fhswr, IPD_Control%fhlwr) if (nint(IPD_Control%fhzero) > 0) then if (mod(isec,3600*nint(IPD_Control%fhzero)) == 0) diag_time = Atmos%Time @@ -1686,7 +1686,7 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - tem = 100.0_kind_phys * max(zero, min(0.1_kind_phys, datar8(i,j))) + tem = 100.0_IPD_kind_phys * max(zero, min(0.1_IPD_kind_phys, datar8(i,j))) IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem IPD_Data(nb)%Sfcprop%zorlo(ix) = tem From 6a30d2cb5c5358dcaecf44f63a54c8daa763b208 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Apr 2020 10:54:14 +0000 Subject: [PATCH 40/91] after merging with fv3atm after ccn update and some bug fix --- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 15 +++- gfsphysics/GFS_layer/GFS_typedefs.meta | 7 ++ gfsphysics/physics/m_micro_driver.F90 | 3 +- gfsphysics/physics/sfc_cice.f | 27 +++++-- gfsphysics/physics/sfc_sice.f | 80 +++++++++++---------- 5 files changed, 85 insertions(+), 47 deletions(-) diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 8fb88d492..7325cfcb2 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -1964,9 +1964,10 @@ subroutine GFS_physics_driver & flag_cice, flag_iter, & Coupling%dqsfcin_cpl, Coupling%dtsfcin_cpl, & Coupling%dusfcin_cpl, Coupling%dvsfcin_cpl, & + Coupling%hsnoin_cpl, & ! --- outputs: qss3(:,2), cmm3(:,2), chh3(:,2), evap3(:,2), hflx3(:,2), & - stress3(:,2)) + stress3(:,2), weasd3(:,2), snowd3(:,2), ep1d3(:,2)) endif !*## CCPP ## @@ -2105,11 +2106,15 @@ subroutine GFS_physics_driver & Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land stress(i) = stress3(i,1) ! Sfcprop%tprcp(i) = tprcp3(i,1) + Sfcprop%tsfco(i) = tsfc3(i,1) + Sfcprop%tisfc(i) = tsfc3(i,1) elseif (islmsk(i) == 0) then k = 3 Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake (and ocean when uncoupled) stress(i) = stress3(i,3) ! Sfcprop%tprcp(i) = tprcp3(i,3) + Sfcprop%tisfc(i) = tsfc3(i,3) + Sfcprop%tsfcl(i) = tsfc3(i,3) else k = 2 stress(i) = stress3(i,2) @@ -2140,7 +2145,7 @@ subroutine GFS_physics_driver & Sfcprop%zorlo(i) = zorl3(i,3) if (flag_cice(i)) then - if (wet(i) .and. fice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + if (wet(i) .and. fice(i) > Model%min_seaice) then ! this was already done for lake ice in sfc_sice txi = fice(i) txo = one - txi evap(i) = txi * evap3(i,2) + txo * evap3(i,3) @@ -2158,6 +2163,12 @@ subroutine GFS_physics_driver & Sfcprop%tisfc(i) = Sfcprop%tsfc(i) icy(i) = .false. endif + Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) + if (wet(i)) then + Sfcprop%tsfco(i) = tsfc3(i,3) + else + Sfcprop%tsfco(i) =Sfcprop%tsfc(i) + endif enddo endif ! if (Model%frac_grid) !*## CCPP ## diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index f02602277..4a5f0e6aa 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -1771,6 +1771,13 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys +[hsnoin_cpl] + standard_name = surface_snow_thickness_for_coupling + long_name = sfc snow depth in meters over sea ice for coupling + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys [slimskin_cpl] standard_name = sea_land_ice_mask_in long_name = sea/land/ice mask input (=0/1/2) diff --git a/gfsphysics/physics/m_micro_driver.F90 b/gfsphysics/physics/m_micro_driver.F90 index 7d14f5faa..276a2f3bc 100644 --- a/gfsphysics/physics/m_micro_driver.F90 +++ b/gfsphysics/physics/m_micro_driver.F90 @@ -533,7 +533,6 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & NCPL(i,l) = MAX( NCPL(i,l), zero) NCPI(i,l) = MAX( NCPI(i,l), zero) RAD_CF(i,l) = max(zero, min(CLLS(i,l)+CLCN(i,l), one)) - if (.not. iccn) then if (iccn /= 1) then CDNC_NUC(i,l) = zero INC_NUC(i,l) = zero @@ -594,7 +593,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & else AERMASSMIX(:,:,1:5) = 1.0d-6 AERMASSMIX(:,:,6:15) = 2.0d-14 - end if + endif call AerConversion1 (AERMASSMIX, AeroProps) deallocate(AERMASSMIX) diff --git a/gfsphysics/physics/sfc_cice.f b/gfsphysics/physics/sfc_cice.f index 2a273688d..8e28b8f5d 100644 --- a/gfsphysics/physics/sfc_cice.f +++ b/gfsphysics/physics/sfc_cice.f @@ -29,9 +29,10 @@ subroutine sfc_cice & ! --- inputs: & ( im, t1, q1, cm, ch, prsl1, & & wind, flag_cice, flag_iter, dqsfc, dtsfc, & - & dusfc, dvsfc, & + & dusfc, dvsfc, snowd, & +! --- input/output: ! --- outputs: - & qsurf, cmm, chh, evap, hflx, stress ) + & qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep) ! ===================================================================== ! ! description: ! @@ -43,6 +44,8 @@ subroutine sfc_cice & ! inputs: ! ! ( im, t1, q1, cm, ch, prsl1, ! ! wind, flag_cice, flag_iter, dqsfc, dtsfc, ! +! --- input/output: ! +! weasd, ep, trpcp, ! ! outputs: ! ! qsurf, cmm, chh, evap, hflx) ! ! ! @@ -64,6 +67,8 @@ subroutine sfc_cice & ! dusfc - real, zonal momentum stress ! dvsfc - real, meridional momentum stress ! dvsfc - real, sensible heat flux +! showd - real, snow depth from cice +! input/outputs: ! outputs: ! qsurf - real, specific humidity at sfc ! cmm - real, ? @@ -71,26 +76,33 @@ subroutine sfc_cice & ! evap - real, evaperation from latent heat ! hflx - real, sensible heat ! stress - real, surface stress +! weasd - real, water equivalent accumulated snow depth (mm) +! snwdph - real, water equivalent snow depth (mm) +! ep - real, potential evaporation + ! ==================== end of description ===================== ! ! ! ! --- constant parameters: - real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: one = 1.0_kind_phys real(kind=kind_phys), parameter :: cpinv = one/cp real(kind=kind_phys), parameter :: hvapi = one/hvap + real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys ! --- inputs: integer, intent(in) :: im ! real (kind=kind_phys), dimension(im), intent(in) :: u1, v1, & real (kind=kind_phys), dimension(im), intent(in) :: & - & t1, q1, cm, ch, prsl1, wind, dqsfc, dtsfc, dusfc, dvsfc + & t1, q1, cm, ch, prsl1, wind, dqsfc, dtsfc, dusfc, dvsfc, & + & snowd logical, intent(in) :: flag_cice(im), flag_iter(im) ! --- outputs: - real (kind=kind_phys), dimension(im), intent(out) :: qsurf, & - & cmm, chh, evap, hflx, stress + real (kind=kind_phys), dimension(im), intent(inout) :: qsurf, & + & cmm, chh, evap, hflx, stress, & + & weasd, snwdph, ep ! --- locals: @@ -111,6 +123,9 @@ subroutine sfc_cice & hflx(i) = dtsfc(i) * tem * cpinv evap(i) = dqsfc(i) * tem * hvapi stress(i) = sqrt(dusfc(i)*dusfc(i) + dvsfc(i)*dvsfc(i)) * tem + weasd(i) = snowd(i) * 1000.0_kind_phys + snwdph(i) = weasd(i) * dsi ! snow depth in mm + ep(i) = evap(i) endif enddo diff --git a/gfsphysics/physics/sfc_sice.f b/gfsphysics/physics/sfc_sice.f index edb8034fe..c3680aa93 100644 --- a/gfsphysics/physics/sfc_sice.f +++ b/gfsphysics/physics/sfc_sice.f @@ -124,18 +124,19 @@ subroutine sfc_sice & ! ! ! --- constant parameters: - integer, parameter :: kmi = 2 ! 2-layer of ice - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 + integer, parameter :: kmi = 2 ! 2-layer of ice + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys real(kind=kind_phys), parameter :: cpinv = one/cp real(kind=kind_phys), parameter :: hvapi = one/hvap real(kind=kind_phys), parameter :: elocp = hvap/cp - real(kind=kind_phys), parameter :: himax = 8.0d0 ! maximum ice thickness allowed - real(kind=kind_phys), parameter :: himin = 0.1d0 ! minimum ice thickness required - real(kind=kind_phys), parameter :: hsmax = 2.0d0 ! maximum snow depth allowed - real(kind=kind_phys), parameter :: timin = 173.0d0 ! minimum temperature allowed for snow/ice - real(kind=kind_phys), parameter :: albfw = 0.06d0 ! albedo for lead - real(kind=kind_phys), parameter :: dsi = one/0.33d0 - real(kind=kind_phys), parameter :: qmin = 1.0d-8 + real(kind=kind_phys), parameter :: himax = 8.0_kind_phys ! maximum ice thickness allowed + real(kind=kind_phys), parameter :: himin = 0.1_kind_phys ! minimum ice thickness required + real(kind=kind_phys), parameter :: hsmax = 2.0_kind_phys ! maximum snow depth allowed + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + real(kind=kind_phys), parameter :: albfw = 0.06_kind_phys ! albedo for lead + real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im, km, ipr @@ -157,7 +158,7 @@ subroutine sfc_sice & real (kind=kind_phys), dimension(im,km), intent(inout) :: stc ! --- outputs: - real (kind=kind_phys), dimension(im), intent(out) :: snwdph, & + real (kind=kind_phys), dimension(im), intent(inout) :: snwdph, & & qsurf, snowmt, gflux, cmm, chh, evap, hflx ! --- locals: @@ -244,7 +245,7 @@ subroutine sfc_sice & ! --- ... snow depth in water equivalent is converted from mm to m unit - snowd(i) = weasd(i) * 0.001d0 + snowd(i) = weasd(i) * 0.001_kind_phys ! flagsnw(i) = .false. ! --- ... when snow depth is less than 1 mm, a patchy snow is assumed and @@ -265,7 +266,8 @@ subroutine sfc_sice & ! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) snetw(i) = sfcdsw(i) * (one - albfw) - snetw(i) = min(3.0d0*sfcnsw(i)/(one+2.0d0*ffw(i)), snetw(i)) + snetw(i) = min(3.0_kind_phys*sfcnsw(i) & + & / (one+2.0_kind_phys*ffw(i)), snetw(i)) sneti(i) = (sfcnsw(i) - ffw(i)*snetw(i)) / fice(i) t12 = tice(i) * tice(i) @@ -275,7 +277,7 @@ subroutine sfc_sice & hfi(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapi(i) & & + rch(i)*(tice(i) - theta1(i)) - hfd(i) = 4.0d0*sfcemis(i)*sbc*tice(i)*t12 & + hfd(i) = 4.0_kind_phys*sfcemis(i)*sbc*tice(i)*t12 & & + (one + elocp*eps*hvap*qs1/(rd*t12)) * rch(i) @@ -287,13 +289,13 @@ subroutine sfc_sice & ! hfw(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapw(i) & ! & + rch(i)*(tgice - theta1(i)) - snetw(i) - focn(i) = 2.0d0 ! heat flux from ocean - should be from ocn model + focn(i) = 2.0_kind_phys ! heat flux from ocean - should be from ocn model snof(i) = zero ! snowfall rate - snow accumulates in gbphys hice(i) = max( min( hice(i), himax ), himin ) snowd(i) = min( snowd(i), hsmax ) - if (snowd(i) > (2.0d0*hice(i))) then + if (snowd(i) > (2.0_kind_phys*hice(i))) then print *, 'warning: too much snow :',snowd(i) snowd(i) = hice(i) + hice(i) print *,'fix: decrease snow depth to:',snowd(i) @@ -357,7 +359,7 @@ subroutine sfc_sice & ! --- ... convert snow depth back to mm of water equivalent - weasd(i) = snowd(i) * 1000.0d0 + weasd(i) = snowd(i) * 1000.0_kind_phys snwdph(i) = weasd(i) * dsi ! snow depth in mm tem = one / rho(i) @@ -438,28 +440,32 @@ subroutine ice3lay ! ! --- constant parameters: (properties of ice, snow, and seawater) - real (kind=kind_phys), parameter :: ds = 330.0d0 ! snow (ov sea ice) density (kg/m^3) - real (kind=kind_phys), parameter :: dw =1000.0d0 ! fresh water density (kg/m^3) + real (kind=kind_phys), parameter :: ds = 330.0_kind_phys ! snow (ov sea ice) density (kg/m^3) + real (kind=kind_phys), parameter :: dw =1000.0_kind_phys ! fresh water density (kg/m^3) real (kind=kind_phys), parameter :: dsdw = ds/dw real (kind=kind_phys), parameter :: dwds = dw/ds - real (kind=kind_phys), parameter :: ks = 0.31d0 ! conductivity of snow (w/mk) - real (kind=kind_phys), parameter :: i0 = 0.3d0 ! ice surface penetrating solar fraction - real (kind=kind_phys), parameter :: ki = 2.03d0 ! conductivity of ice (w/mk) - real (kind=kind_phys), parameter :: di = 917.0d0 ! density of ice (kg/m^3) + real (kind=kind_phys), parameter :: ks = 0.31_kind_phys ! conductivity of snow (w/mk) + real (kind=kind_phys), parameter :: i0 = 0.3_kind_phys ! ice surface penetrating solar fraction + real (kind=kind_phys), parameter :: ki = 2.03_kind_phys ! conductivity of ice (w/mk) + real (kind=kind_phys), parameter :: di = 917.0_kind_phys ! density of ice (kg/m^3) real (kind=kind_phys), parameter :: didw = di/dw real (kind=kind_phys), parameter :: dsdi = ds/di - real (kind=kind_phys), parameter :: ci = 2054.0d0 ! heat capacity of fresh ice (j/kg/k) - real (kind=kind_phys), parameter :: li = 3.34d5 ! latent heat of fusion (j/kg-ice) - real (kind=kind_phys), parameter :: si = 1.0d0 ! salinity of sea ice - real (kind=kind_phys), parameter :: mu = 0.054d0 ! relates freezing temp to salinity - real (kind=kind_phys), parameter :: tfi = -mu*si ! sea ice freezing temp = -mu*salinity - real (kind=kind_phys), parameter :: tfw = -1.8d0 ! tfw - seawater freezing temp (c) - real (kind=kind_phys), parameter :: tfi0 = tfi-0.0001d0 + real (kind=kind_phys), parameter :: ci = 2054.0_kind_phys ! heat capacity of fresh ice (j/kg/k) + real (kind=kind_phys), parameter :: li = 3.34e5_kind_phys ! latent heat of fusion (j/kg-ice) + real (kind=kind_phys), parameter :: si = 1.0_kind_phys ! salinity of sea ice + real (kind=kind_phys), parameter :: mu = 0.054_kind_phys ! relates freezing temp to salinity + real (kind=kind_phys), parameter :: tfi = -mu*si ! sea ice freezing temp = -mu*salinity + real (kind=kind_phys), parameter :: tfw = -1.8_kind_phys ! tfw - seawater freezing temp (c) + real (kind=kind_phys), parameter :: tfi0 = tfi-0.0001_kind_phys real (kind=kind_phys), parameter :: dici = di*ci real (kind=kind_phys), parameter :: dili = di*li real (kind=kind_phys), parameter :: dsli = ds*li - real (kind=kind_phys), parameter :: ki4 = ki*4.0d0 - real (kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 + real (kind=kind_phys), parameter :: ki4 = ki*4.0_kind_phys + + real (kind=kind_phys), parameter :: zero = 0.0_kind_phys + real (kind=kind_phys), parameter :: half = 0.5_kind_phys + real (kind=kind_phys), parameter :: one = 1.0_kind_phys + real (kind=kind_phys), parameter :: four = 4.0_kind_phys ! --- inputs: integer, intent(in) :: im, kmi, ipr @@ -541,13 +547,13 @@ subroutine ice3lay b1 = b10 + ai * wrk1 c1 = dili * tfi * dt2i * hice(i) - stsice(i,1) = -(sqrt(b1*b1 - 4.0d0*a1*c1) + b1)/(a1+a1) + stsice(i,1) = -(sqrt(b1*b1 - four*a1*c1) + b1)/(a1+a1) tice(i) = (k12*stsice(i,1) - ai) / (k12 + bi) if (tice(i) > tsf) then a1 = a10 + k12 b1 = b10 - k12*tsf - stsice(i,1) = -(sqrt(b1*b1 - 4.0d0*a1*c1) + b1)/(a1+a1) + stsice(i,1) = -(sqrt(b1*b1 - four*a1*c1) + b1)/(a1+a1) tice(i) = tsf tmelt = (k12*(stsice(i,1)-tsf) - (ai+bi*tsf)) * delt else @@ -562,8 +568,8 @@ subroutine ice3lay ! --- ... resize the ice ... - h1 = 0.5d0 * hice(i) - h2 = 0.5d0 * hice(i) + h1 = half * hice(i) + h2 = half * hice(i) ! --- ... top ... @@ -592,7 +598,7 @@ subroutine ice3lay hice(i) = h1 + h2 if (hice(i) > zero) then - if (h1 > 0.5d0*hice(i)) then + if (h1 > half*hice(i)) then f1 = one - (h2+h2) / hice(i) stsice(i,2) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& & + (one - f1)*stsice(i,2) @@ -606,7 +612,7 @@ subroutine ice3lay stsice(i,1) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& & + (one - f1)*stsice(i,2) stsice(i,1) = (stsice(i,1) - sqrt(stsice(i,1)*stsice(i,1) & - & - 4.0d0*tfi*li/ci)) * 0.5d0 + & - four*tfi*li/ci)) * half endif k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) From 9c9cc04081c4108eff8c21ef2dfc489ea8773982 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Apr 2020 11:09:19 +0000 Subject: [PATCH 41/91] fixing some comment lines --- ccpp/physics | 2 +- gfsphysics/physics/sfc_cice.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index e19953d0d..f85730de9 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit e19953d0da2ccd4b65bc4ac68a2cc09807805474 +Subproject commit f85730de98a126e7552b4bdc9d31ceb9c3ae067d diff --git a/gfsphysics/physics/sfc_cice.f b/gfsphysics/physics/sfc_cice.f index 8e28b8f5d..6e4f7ddb5 100644 --- a/gfsphysics/physics/sfc_cice.f +++ b/gfsphysics/physics/sfc_cice.f @@ -67,7 +67,7 @@ subroutine sfc_cice & ! dusfc - real, zonal momentum stress ! dvsfc - real, meridional momentum stress ! dvsfc - real, sensible heat flux -! showd - real, snow depth from cice +! snowd - real, snow depth from cice ! input/outputs: ! outputs: ! qsurf - real, specific humidity at sfc From 2892c929792188152d19546ddf2c99a97a1c8a66 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Apr 2020 11:12:24 +0000 Subject: [PATCH 42/91] fixing some comment lines --- ccpp/physics | 2 +- gfsphysics/physics/sfc_cice.f | 6 ++---- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index f85730de9..024144911 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit f85730de98a126e7552b4bdc9d31ceb9c3ae067d +Subproject commit 02414491112c736f75081f26ad508c70925d265a diff --git a/gfsphysics/physics/sfc_cice.f b/gfsphysics/physics/sfc_cice.f index 6e4f7ddb5..970d4d80b 100644 --- a/gfsphysics/physics/sfc_cice.f +++ b/gfsphysics/physics/sfc_cice.f @@ -44,10 +44,9 @@ subroutine sfc_cice & ! inputs: ! ! ( im, t1, q1, cm, ch, prsl1, ! ! wind, flag_cice, flag_iter, dqsfc, dtsfc, ! -! --- input/output: ! -! weasd, ep, trpcp, ! +! dusfc, dvsfc, snowd, ! ! outputs: ! -! qsurf, cmm, chh, evap, hflx) ! +! qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep) ! ! ! ! ==================== defination of variables ==================== ! ! ! @@ -68,7 +67,6 @@ subroutine sfc_cice & ! dvsfc - real, meridional momentum stress ! dvsfc - real, sensible heat flux ! snowd - real, snow depth from cice -! input/outputs: ! outputs: ! qsurf - real, specific humidity at sfc ! cmm - real, ? From 0c2bf169e44e3eb196ef0fc4fa687b7dc66ce872 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Apr 2020 14:21:30 +0000 Subject: [PATCH 43/91] minor update to ipd phys driver --- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 024144911..4694c0088 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 02414491112c736f75081f26ad508c70925d265a +Subproject commit 4694c008851cceb7ef1977b48d00067f49fca69d diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 7325cfcb2..2967d1d87 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -2152,6 +2152,8 @@ subroutine GFS_physics_driver & hflx(i) = txi * hflx3(i,2) + txo * hflx3(i,3) Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) stress(i) = txi *stress3(i,2) + txo * stress3(i,3) + qss(i) = txi * qss3(i,2) + txo * qss3(i,3) + ep1d(i) = txi * ep1d3(i,2) + txo * ep1d(i,3) endif elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) From 71f31436f84f24d243f8d038372080b49fa795c4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 28 Apr 2020 13:25:57 +0000 Subject: [PATCH 44/91] some additional updates - not necessarily completely correct --- atmos_model.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 05856e067..dfc22ad2c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1936,15 +1936,18 @@ subroutine assign_importdata(rc) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then !if it is ocean or ice get surface temperature from mediator if(IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then - IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tisfcin_cpl(ix) - IPD_Data(nb)%Sfcprop%fice(ix) = IPD_Data(nb)%Coupling%ficein_cpl(ix) - IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) - IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) + IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tisfcin_cpl(ix) + IPD_Data(nb)%Sfcprop%fice(ix) = IPD_Data(nb)%Coupling%ficein_cpl(ix) + IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) +! IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) + IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) & + / max(0.01, IPD_Data(nb)%Coupling%ficein_cpl(ix)) else - IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) - IPD_Data(nb)%Sfcprop%fice(ix) = zero - IPD_Data(nb)%Sfcprop%hice(ix) = zero - IPD_Data(nb)%Sfcprop%snowd(ix) = zero + IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) + IPD_Data(nb)%Sfcprop%fice(ix) = zero + IPD_Data(nb)%Sfcprop%hice(ix) = zero +! IPD_Data(nb)%Sfcprop%snowd(ix) = zero + IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = zero ! IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! over open water - should not be used in ATM IPD_Data(nb)%Coupling%dqsfcin_cpl(ix) = -99999.0 ! ,, From 3e8150a64b49e4eb409f54fa19412f5353751b09 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 29 Apr 2020 13:08:39 +0000 Subject: [PATCH 45/91] testing an alternate option --- ccpp/physics | 2 +- gfsphysics/physics/sfc_cice.f | 9 +++++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 4694c0088..e216116db 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 4694c008851cceb7ef1977b48d00067f49fca69d +Subproject commit e216116dbccb9b456a3c3eaf33d7bc5cca890725 diff --git a/gfsphysics/physics/sfc_cice.f b/gfsphysics/physics/sfc_cice.f index 970d4d80b..64a2565cb 100644 --- a/gfsphysics/physics/sfc_cice.f +++ b/gfsphysics/physics/sfc_cice.f @@ -121,8 +121,13 @@ subroutine sfc_cice & hflx(i) = dtsfc(i) * tem * cpinv evap(i) = dqsfc(i) * tem * hvapi stress(i) = sqrt(dusfc(i)*dusfc(i) + dvsfc(i)*dvsfc(i)) * tem - weasd(i) = snowd(i) * 1000.0_kind_phys - snwdph(i) = weasd(i) * dsi ! snow depth in mm + + snwdph(i) = snowd(i) * 1000.0_kind_phys + weasd(i) = snwdph(i) * 0.33_kind_phys + +! weasd(i) = snowd(i) * 1000.0_kind_phys +! snwdph(i) = weasd(i) * dsi ! snow depth in mm + ep(i) = evap(i) endif enddo From a4fd1add4ffaf29777ce830a81a623e1fe8f5591 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 30 Apr 2020 02:01:21 +0000 Subject: [PATCH 46/91] some additional update to ipd driver --- atmos_model.F90 | 2 +- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 184 ++++++++++---------- 3 files changed, 94 insertions(+), 94 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index dfc22ad2c..d2f65520c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1941,7 +1941,7 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) ! IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) & - / max(0.01, IPD_Data(nb)%Coupling%ficein_cpl(ix)) + / max(0.01_IPD_kind_phys, IPD_Data(nb)%Coupling%ficein_cpl(ix)) else IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) IPD_Data(nb)%Sfcprop%fice(ix) = zero diff --git a/ccpp/physics b/ccpp/physics index e216116db..d61ecbe02 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit e216116dbccb9b456a3c3eaf33d7bc5cca890725 +Subproject commit d61ecbe02a64c872212644cd472de77ee73605e2 diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 2967d1d87..bfdf8f4b6 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -44,22 +44,22 @@ module module_physics_driver !--- CONSTANT PARAMETERS real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp - real(kind=kind_phys), parameter :: epsln = 1.0d-10 - real(kind=kind_phys), parameter :: qmin = 1.0d-8 - real(kind=kind_phys), parameter :: qsmall = 1.0d-20 - real(kind=kind_phys), parameter :: rainmin = 1.0d-13 - real(kind=kind_phys), parameter :: p850 = 85000.0d0 - real(kind=kind_phys), parameter :: epsq = 1.0d-20 + real(kind=kind_phys), parameter :: epsln = 1.0e-10_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys + real(kind=kind_phys), parameter :: qsmall = 1.0e-20_kind_phys + real(kind=kind_phys), parameter :: rainmin = 1.0e-13_kind_phys + real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys + real(kind=kind_phys), parameter :: epsq = 1.0e-20_kind_phys real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus - real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0, & - half = 0.5d0, onebg = one/con_g - real(kind=kind_phys), parameter :: albdf = 0.06d0 - real(kind=kind_phys), parameter :: tf=258.16d0, tcr=273.16d0, tcrf=one/(tcr-tf) - real(kind=kind_phys), parameter :: con_p001= 0.001d0 - real(kind=kind_phys), parameter :: con_day = 86400.0d0 - real(kind=kind_phys), parameter :: rad2dg = 180.0d0/con_pi - real(kind=kind_phys), parameter :: omz1 = 10.0d0 + real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, & + half = 0.5_kind_phys, onebg = one/con_g + real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys + real(kind=kind_phys), parameter :: tf=258.16_kind_phys, tcr=273.16_kind_phys, tcrf=one/(tcr-tf) + real(kind=kind_phys), parameter :: con_p001= 0.001_kind_phys + real(kind=kind_phys), parameter :: con_day = 86400.0_kind_phys + real(kind=kind_phys), parameter :: rad2dg = 180.0_kind_phys/con_pi + real(kind=kind_phys), parameter :: omz1 = 10.0_kind_phys real(kind=kind_phys), parameter :: huge = zero !> GFS Physics Implementation Layer @@ -1042,7 +1042,7 @@ subroutine GFS_physics_driver & !## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run do i = 1, IM - sigmaf(i) = max( Sfcprop%vfrac(i),0.01d0 ) + sigmaf(i) = max( Sfcprop%vfrac(i),0.01_kind_phys ) islmsk(i) = nint(Sfcprop%slmsk(i)) if (islmsk(i) == 2) then @@ -1058,9 +1058,9 @@ subroutine GFS_physics_driver & endif slopetyp(i) = 9 else - soiltyp(i) = int( Sfcprop%stype(i)+0.5 ) - vegtype(i) = int( Sfcprop%vtype(i)+0.5 ) - slopetyp(i) = int( Sfcprop%slope(i)+0.5 ) !! clu: slope -> slopetyp + soiltyp(i) = int( Sfcprop%stype(i)+half ) + vegtype(i) = int( Sfcprop%vtype(i)+half ) + slopetyp(i) = int( Sfcprop%slope(i)+half ) !! clu: slope -> slopetyp if (soiltyp(i) < 1) soiltyp(i) = 14 if (vegtype(i) < 1) vegtype(i) = 17 if (slopetyp(i) < 1) slopetyp(i) = 1 @@ -1237,7 +1237,7 @@ subroutine GFS_physics_driver & ! snowd3(i,3) = Sfcprop%snowd(i) snowd3(i,3) = zero weasd3(i,3) = zero - semis3(i,3) = 0.984d0 + semis3(i,3) = 0.984_kind_phys endif ! if (dry(i)) then ! Land @@ -1259,7 +1259,7 @@ subroutine GFS_physics_driver & snowd3(i,2) = Sfcprop%snowd(i) ep1d3(i,2) = zero gflx3(i,2) = zero - semis3(i,2) = 0.95d0 + semis3(i,2) = 0.95_kind_phys endif enddo !*## CCPP ## @@ -1515,7 +1515,7 @@ subroutine GFS_physics_driver & do i=1,im if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg tem1 = adjsfcdsw(i) / xcosz(i) - if ( tem1 >= 120.0d0 ) then + if ( tem1 >= 120.0_kind_phys) then Diag%suntim(i) = Diag%suntim(i) + dtf endif endif @@ -1597,8 +1597,8 @@ subroutine GFS_physics_driver & kinver(i) = levs !## CCPP ## GFS_typedefs.F90/interstitial_phys_reset invrsn(i) = .false. tx1(i) = zero - tx2(i) = 10.0d0 - ctei_r(i) = 10.0d0 + tx2(i) = 10.0_kind_phys + ctei_r(i) = 10.0_kind_phys enddo ! Only used for old shallow convection with mstrat=.true. @@ -1608,12 +1608,12 @@ subroutine GFS_physics_driver & ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) do k=1,levs/2 do i=1,im - if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35d0*Statein%prsi(i,1) & + if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35_kind_phys*Statein%prsi(i,1) & .and. (.not. invrsn(i))) then tem = (Statein%tgrs(i,k+1) - Statein%tgrs(i,k)) & / (Statein%prsl(i,k) - Statein%prsl(i,k+1)) - if (((tem > 0.00010d0) .and. (tx1(i) < zero)) .or. & + if (((tem > 0.00010_kind_phys) .and. (tx1(i) < zero)) .or. & ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then invrsn(i) = .true. @@ -1627,7 +1627,7 @@ subroutine GFS_physics_driver & ctei_r(i) = (one/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & + Statein%qgrs(i,k+1,ntcw)-Statein%qgrs(i,k,ntcw)) else - ctei_r(i) = 10.0d0 + ctei_r(i) = 10.0_kind_phys endif if ( ctei_rml(i) > ctei_r(i) ) then @@ -1670,7 +1670,7 @@ subroutine GFS_physics_driver & Diag%smcref2(i) = zero wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0d0)), one) + + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0_kind_phys)), one) !*## CCPP ## enddo !*## CCPP ## @@ -1706,7 +1706,7 @@ subroutine GFS_physics_driver & !*## CCPP ## !## CCPP ##* GFS_surface_loop_control/GFS_surface_loop_control_part1_run do i=1,im - if (iter == 1 .and. wind(i) < 2.0d0) then + if (iter == 1 .and. wind(i) < 2.0_kind_phys) then flag_guess(i) = .true. endif enddo @@ -1780,8 +1780,8 @@ subroutine GFS_physics_driver & ! --- ... run nsst model ... --- if (Model%nstf_name(1) > 1) then - zsea1 = 0.001d0*real(Model%nstf_name(4)) - zsea2 = 0.001d0*real(Model%nstf_name(5)) + zsea1 = 0.001_kind_phys*real(Model%nstf_name(4)) + zsea2 = 0.001_kind_phys*real(Model%nstf_name(5)) call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & Sfcprop%z_c, wet, zsea1, zsea2, im, 1, dtzm) do i=1,im @@ -2010,7 +2010,7 @@ subroutine GFS_physics_driver & flag_iter(i) = .false. flag_guess(i) = .false. - if (iter == 1 .and. wind(i) < 2.0d0) then + if (iter == 1 .and. wind(i) < 2.0_kind_phys) then ! if (dry(i) .or. (wet(i) .and. .not.icy(i) & if (dry(i) .or. (wet(i) .and. Model%nstf_name(1) > 0)) then flag_iter(i) = .true. @@ -2088,11 +2088,11 @@ subroutine GFS_physics_driver & ! endif if (.not. flag_cice(i)) then - if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array + if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array Sfcprop%hice(i) = zice(i) Sfcprop%fice(i) = fice(i) Sfcprop%tisfc(i) = tice(i) - else ! this would be over open ocean or land (no ice fraction) + else ! this would be over open ocean or land (no ice fraction) Sfcprop%hice(i) = zero Sfcprop%fice(i) = zero Sfcprop%tisfc(i) = Sfcprop%tsfc(i) @@ -2156,7 +2156,7 @@ subroutine GFS_physics_driver & ep1d(i) = txi * ep1d3(i,2) + txo * ep1d(i,3) endif elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array - Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) Sfcprop%hice(i) = zice(i) Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen else ! this would be over open ocean or land (no ice fraction) @@ -2262,11 +2262,11 @@ subroutine GFS_physics_driver & if (wet(i)) then ! some open water ! --- compute open water albedo xcosz_loc = max( zero, min( one, xcosz(i) )) - ocalnirdf_cpl(i) = 0.06d0 - ocalnirbm_cpl(i) = max(albdf, 0.026d0/(xcosz_loc**1.7d0+0.065d0) & - & + 0.15d0 * (xcosz_loc-0.1d0) * (xcosz_loc-0.5d0) & + ocalnirdf_cpl(i) = 0.06_kind_phys + ocalnirbm_cpl(i) = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) & + & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) & & * (xcosz_loc-one)) - ocalvisdf_cpl(i) = 0.06d0 + ocalvisdf_cpl(i) = 0.06 ocalvisbm_cpl(i) = ocalnirbm_cpl(i) Coupling%nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl(i)) @@ -3102,7 +3102,7 @@ subroutine GFS_physics_driver & if (ntke > 0) then tke(1:im,:) = Statein%qgrs(1:im,:,ntke) + dqdt(1:im,:,ntke) * dtp else - tke(:,:) = -9999.0d0 + tke(:,:) = -9999.0_kind_phys endif ! ! tendency without PBL-accumulations @@ -3379,7 +3379,7 @@ subroutine GFS_physics_driver & do k=1,levs do i=1,im clw(i,k,1) = zero - clw(i,k,2) = -999.9d0 + clw(i,k,2) = -999.9_kind_phys enddo enddo @@ -3448,7 +3448,7 @@ subroutine GFS_physics_driver & !## CCPP ## GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run if (ntcw > 0) then ! if (imp_physics == Model%imp_physics_mg .and. .not. Model%do_shoc) then ! compute rhc for GMAO macro physics cloud pdf - if (imp_physics == Model%imp_physics_mg .and. Model%crtrh(2) < 0.5d0) then ! compute rhc for GMAO macro physics cloud pdf + if (imp_physics == Model%imp_physics_mg .and. Model%crtrh(2) < half) then ! compute rhc for GMAO macro physics cloud pdf do i=1,im tx1(i) = one / Statein%prsi(i,1) tx2(i) = one - rhc_max*work1(i) - Model%crtrh(1)*work2(i) @@ -3459,20 +3459,20 @@ subroutine GFS_physics_driver & do k = 1, levs do i = 1, im tem = Statein%prsl(i,k) * tx1(i) - tem1 = min(max((tem-tx3(i))*slope_mg, -20.0d0), 20.0d0) + tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) ! ! Using crtrh(2) and crtrh(3) from the namelist instead of 0.3 and 0.2 ! and crtrh(1) represents pbl top critical relative humidity - tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0d0), 20.0d0) + tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) if (islmsk(i) > 0) then tem1 = one / (one+exp(tem1+tem1)) else - tem1 = 2.0d0 / (one+exp(tem1+tem1)) + tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) endif tem2 = one / (one+exp(tem2)) - rhc(i,k) = min(rhc_max, max(0.7d0, one-tx2(i)*tem1*tem2)) + rhc(i,k) = min(rhc_max, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) enddo enddo else @@ -3907,7 +3907,7 @@ subroutine GFS_physics_driver & do k=1,levs kk = min(k+1,levs) ! assuming no cloud top reaches the model top do i=1,im !DD - sigmafrac(i,k) = 0.5d0 * (sigmatot(i,k)+sigmatot(i,kk)) + sigmafrac(i,k) = half * (sigmatot(i,k)+sigmatot(i,kk)) enddo enddo endif @@ -3933,7 +3933,7 @@ subroutine GFS_physics_driver & enddo else do i=1,im - ccwfac(i) = -999.0d0 + ccwfac(i) = -999.0_kind_phys dlqfac(i) = zero psaur_l(i) = Model%psauras(1)*work1(i) + Model%psauras(2)*work2(i) praur_l(i) = Model%prauras(1)*work1(i) + Model%prauras(2)*work2(i) @@ -3953,8 +3953,8 @@ subroutine GFS_physics_driver & revap = .true. ! if (ncld ==2) revap = .false. - trcmin(:) = -999999.0d0 - if (ntk-2 > 0) trcmin(ntk-2) = 1.0d-4 + trcmin(:) = -999999.0_kind_phys + if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4_kind_phys !*## CCPP ## ! if (lprnt) write(0,*)' gt04bras=',Stateout%gt0(ipr,:) ! if (lprnt) write(0,*)' gq04bras=',Stateout%gq0(ipr,:,1) @@ -4265,10 +4265,10 @@ subroutine GFS_physics_driver & do k=1,levs do i=1,im - eng0 = 0.5d0*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + eng0 = half*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp - eng1 = 0.5d0*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + eng1 = half*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) Stateout%gt0(i,k) = Stateout%gt0(i,k) + (eng0-eng1)/(dtp*con_cp) enddo ! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', @@ -4413,7 +4413,7 @@ subroutine GFS_physics_driver & levshc(:) = 0 do k=2,levs do i=1,im - dpshc = 0.3d0 * Statein%prsi(i,1) + dpshc = 0.3_kind_phys * Statein%prsi(i,1) if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k enddo enddo @@ -4464,7 +4464,7 @@ subroutine GFS_physics_driver & ! do k=1,levs do i=1,im - if (clw(i,k,2) <= -999.0d0) clw(i,k,2) = zero + if (clw(i,k,2) <= -999.0_kind_phys) clw(i,k,2) = zero enddo enddo !*## CCPP ## @@ -5200,8 +5200,8 @@ subroutine GFS_physics_driver & if (Model%effr_in) then do i =1, im - den(i,k) = 0.622d0*Statein%prsl(i,k) / & - (con_rd*Stateout%gt0(i,k)*(Stateout%gq0(i,k,1)+0.622d0)) + den(i,k) = 0.622_kind_phys*Statein%prsl(i,k) / & + (con_rd*Stateout%gt0(i,k)*(Stateout%gq0(i,k,1)+0.622_kind_phys)) enddo endif enddo @@ -5216,8 +5216,8 @@ subroutine GFS_physics_driver & call max_fields(Statein%phil,Diag%refl_10cm,con_g,im,levs,refd,Stateout%gt0,refd263k) if (reset) then do i=1,im - Diag%refdmax(I) = -35.0d0 - Diag%refdmax263k(I) = -35.0d0 + Diag%refdmax(I) = -35.0_kind_phys + Diag%refdmax263k(I) = -35.0_kind_phys enddo endif do i=1,im @@ -5411,14 +5411,15 @@ subroutine GFS_physics_driver & enddo enddo - if (Model%imp_physics == Model%imp_physics_gfdl) then + if (Model%imp_physics == Model%imp_physics_gfdl) then ! GFDL microphysics + ! ----------------- ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP tem = dtp * con_p001 / con_day do i = 1, im Sfcprop%tprcp(i) = max(zero, Diag%rain(i) )! clu: rain -> tprcp Sfcprop%srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (Sfcprop%tsfc(i) >= 273.15d0) then + if (Sfcprop%tsfc(i) >= 273.15_kind_phys) then crain = Diag%rainc(i) csnow = zero else @@ -5446,12 +5447,13 @@ subroutine GFS_physics_driver & #endif enddo elseif( .not. Model%cal_pre) then - if (Model%imp_physics == Model%imp_physics_mg) then ! MG microphysics + if (Model%imp_physics == Model%imp_physics_mg) then ! MG microphysics + ! --------------- do i=1,im if (Diag%rain(i) > rainmin) then tem1 = max(zero, (Diag%rain(i)-Diag%rainc(i))) * Diag%sr(i) tem2 = one / Diag%rain(i) - if (t850(i) > 273.16d0) then + if (t850(i) > 273.16_kind_phys) then Sfcprop%srflag(i) = max(zero, min(one, tem1*tem2)) else Sfcprop%srflag(i) = max(zero, min(one, (tem1+Diag%rainc(i))*tem2)) @@ -5461,15 +5463,13 @@ subroutine GFS_physics_driver & Diag%rain(i) = zero Diag%rainc(i) = zero endif - Sfcprop%tprcp(i) = max(zero, Diag%rain(i) ) ! clu: rain -> tprcp + Sfcprop%tprcp(i) = max(zero, Diag%rain(i)) enddo - else + else ! not GFDL or MG microphysics + ! --------------------------- do i = 1, im - Sfcprop%tprcp(i) = max(zero, Diag%rain(i) ) ! clu: rain -> tprcp - Sfcprop%srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16d0) then - Sfcprop%srflag(i) = one ! clu: set srflag to 'snow' (i.e. 1) - endif + Sfcprop%tprcp(i) = max(zero, Diag%rain(i)) + Sfcprop%srflag(i) = Diag%sr(i) enddo endif endif @@ -5662,13 +5662,13 @@ subroutine GFS_physics_driver & if (reset) then do i=1, im ! find max hourly wind speed then decompose - Diag%spd10max(i) = -999. - Diag%u10max(i) = -999. - Diag%v10max(i) = -999. - Diag%t02max(i) = -999. - Diag%t02min(i) = 999. - Diag%rh02max(i) = -999. - Diag%rh02min(i) = 999. + Diag%spd10max(i) = -999.0_kind_phys + Diag%u10max(i) = -999.0_kind_phys + Diag%v10max(i) = -999.0_kind_phys + Diag%t02max(i) = -999.0_kind_phys + Diag%t02min(i) = 999.0_kind_phys + Diag%rh02max(i) = -999.0_kind_phys + Diag%rh02min(i) = 999.0_kind_phys enddo endif do i=1, im @@ -5679,7 +5679,7 @@ subroutine GFS_physics_driver & Diag%u10max(i) = Diag%u10m(i) Diag%v10max(i) = Diag%v10m(i) endif - pshltr = Statein%pgr(i)*exp(-0.068283d0/Stateout%gt0(i,1)) + pshltr = Statein%pgr(i)*exp(-0.068283_kind_phys/Stateout%gt0(i,1)) QCQ = PQ0/pshltr*EXP(A2A*(Sfcprop%t2m(i)-A3)/(Sfcprop%t2m(i)-A4)) rh02 = Sfcprop%q2m(i) / QCQ IF (rh02 > one) THEN @@ -5799,10 +5799,10 @@ subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & integer :: i, k ! do i=1,im - sumqv(i) = 0.0 - sumql(i) = 0.0 - sumqi(i) = 0.0 - sumq (i) = 0.0 + sumqv(i) = 0.0_kind_phys + sumql(i) = 0.0_kind_phys + sumqi(i) = 0.0_kind_phys + sumq (i) = 0.0_kind_phys enddo do k=1,levs do i=1,im @@ -5812,9 +5812,9 @@ subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & enddo enddo do i=1,im - sumqv(i) = - sumqv(i) * (1.0/grav) - sumql(i) = - sumql(i) * (1.0/grav) - sumqi(i) = - sumqi(i) * (1.0/grav) + sumqv(i) = - sumqv(i) * (1.0_kind_phys/grav) + sumql(i) = - sumql(i) * (1.0_kind_phys/grav) + sumqi(i) = - sumqi(i) * (1.0_kind_phys/grav) sumq (i) = sumqv(i) + sumql(i) + sumqi(i) enddo do i=1,im @@ -5847,13 +5847,13 @@ subroutine moist_bud2(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & integer :: i, k ! do i=1,im - sumqv(i) = 0.0 - sumql(i) = 0.0 - sumqi(i) = 0.0 - sumqr(i) = 0.0 - sumqs(i) = 0.0 - sumqg(i) = 0.0 - sumq (i) = 0.0 + sumqv(i) = 0.0_kind_phys + sumql(i) = 0.0_kind_phys + sumqi(i) = 0.0_kind_phys + sumqr(i) = 0.0_kind_phys + sumqs(i) = 0.0_kind_phys + sumqg(i) = 0.0_kind_phys + sumq (i) = 0.0_kind_phys enddo do k=1,levs do i=1,im @@ -5865,7 +5865,7 @@ subroutine moist_bud2(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & sumqg(i) = sumqg(i) + (qg1(i,k) - qg0(i,k)) * delp(i,k) enddo enddo - oneog = 1.0 / grav + oneog = 1.0_kind_phys / grav do i=1,im sumqv(i) = - sumqv(i) * oneog sumql(i) = - sumql(i) * oneog From 83b6c40f57f3f10533793979767388c108e3ade0 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 2 May 2020 23:34:16 +0000 Subject: [PATCH 47/91] some fix and some updates to atmos_model and ipd driver --- atmos_model.F90 | 22 ++++++++++++--------- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 10 +++++----- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index d2f65520c..a2da0dc5d 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1605,7 +1605,7 @@ subroutine assign_importdata(rc) real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: datar42d real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d real(kind=IPD_kind_phys), dimension(:,:), pointer :: datar8 - real(kind=IPD_kind_phys) :: tem + real(kind=IPD_kind_phys) :: tem, ofrac logical found, isFieldCreated, lcpl_fice ! !------------------------------------------------------------------------------ @@ -1746,22 +1746,24 @@ subroutine assign_importdata(rc) findex = QueryFieldList(ImportFieldsList,fldname) if (importFieldsValid(findex)) then lcpl_fice = .true. -!$omp parallel do default(shared) private(i,j,nb,ix) +!$omp parallel do default(shared) private(i,j,nb,ix,ofrac) do j=jsc,jec do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) IPD_Data(nb)%Coupling%ficein_cpl(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = IPD_Data(nb)%Sfcprop%slmsk(ix) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%ficein_cpl(ix) = max(zero, min(one, datar8(i,j)/IPD_Data(nb)%Sfcprop%oceanfrac(ix))) !LHS: ice frac wrt water area + ofrac = IPD_Data(nb)%Sfcprop%oceanfrac(ix) + if (ofrac > zero) then + IPD_Data(nb)%Coupling%ficein_cpl(ix) = max(zero, min(one, datar8(i,j)/ofrac)) !LHS: ice frac wrt water area if (IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then if (IPD_Data(nb)%Coupling%ficein_cpl(ix) > one-epsln) IPD_Data(nb)%Coupling%ficein_cpl(ix) = one - if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4. +! if (abs(one-ofrac) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points + IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys + IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4.0_IPD_kind_phys else IPD_Data(nb)%Coupling%ficein_cpl(ix) = zero - if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) then + if (abs(one-ofrac) < epsln) then IPD_Data(nb)%Sfcprop%slmsk(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero end if @@ -1955,8 +1957,10 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Coupling%dvsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%ulwsfcin_cpl(ix) = -99999.0 ! ,, - if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) & - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero ! 100% open water + if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) then ! 100% open water + IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero + IPD_Data(nb)%Sfcprop%slmsk(ix) = zero + endif endif endif enddo diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index bfdf8f4b6..721fea81b 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -1142,8 +1142,8 @@ subroutine GFS_physics_driver & endif if (fice(i) < one) then wet(i) = .true. ! some open ocean/lake water exists - if (.not. Model%cplflx .or. Sfcprop%oceanfrac(i) == zero) & - Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) + if ((.not. Model%cplflx .or. Sfcprop%oceanfrac(i) == zero) .and. icy(i)) & + Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) endif else fice(i) = zero @@ -1177,8 +1177,8 @@ subroutine GFS_physics_driver & endif if (fice(i) < one) then wet(i)=.true. ! some open ocean/lake water exists - if (.not. Model%cplflx) & - Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) + if (.not. Model%cplflx .and. icy(i)) & + Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) endif endif enddo @@ -2153,7 +2153,7 @@ subroutine GFS_physics_driver & Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) stress(i) = txi *stress3(i,2) + txo * stress3(i,3) qss(i) = txi * qss3(i,2) + txo * qss3(i,3) - ep1d(i) = txi * ep1d3(i,2) + txo * ep1d(i,3) + ep1d(i) = txi * ep1d3(i,2) + txo * ep1d3(i,3) endif elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) From 638bda2199a6d3ad9bb7b292fe784743579e4235 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 4 May 2020 18:31:40 +0000 Subject: [PATCH 48/91] removed tisfcin_cpl and tseain_cpl as they are not needed --- atmos_model.F90 | 13 ++++++++----- gfsphysics/GFS_layer/GFS_typedefs.F90 | 12 ++++++------ 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 23010ea1e..c9aa82474 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1708,7 +1708,8 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) +! IPD_Data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) + IPD_Data(nb)%Sfcprop%tisfc(ix) = datar8(i,j) endif enddo enddo @@ -1730,7 +1731,7 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%tseain_cpl(ix) = datar8(i,j) +! IPD_Data(nb)%Coupling%tseain_cpl(ix) = datar8(i,j) IPD_Data(nb)%Sfcprop%tsfco(ix) = datar8(i,j) endif enddo @@ -1938,14 +1939,15 @@ subroutine assign_importdata(rc) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then !if it is ocean or ice get surface temperature from mediator if(IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then - IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tisfcin_cpl(ix) +! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tisfcin_cpl(ix) IPD_Data(nb)%Sfcprop%fice(ix) = IPD_Data(nb)%Coupling%ficein_cpl(ix) IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) ! IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) & / max(0.01_IPD_kind_phys, IPD_Data(nb)%Coupling%ficein_cpl(ix)) else - IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) +! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) + IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Sfcprop%tsfco(ix) IPD_Data(nb)%Sfcprop%fice(ix) = zero IPD_Data(nb)%Sfcprop%hice(ix) = zero ! IPD_Data(nb)%Sfcprop%snowd(ix) = zero @@ -1976,7 +1978,8 @@ subroutine assign_importdata(rc) ! abs(IPD_Data(nb)%Grid%xlat_d(ix)+58.99) < 0.1) then ! write(0,*)' in assign tisfc=',IPD_Data(nb)%Sfcprop%tisfc(ix), & ! ' oceanfrac=',IPD_Data(nb)%Sfcprop%oceanfrac(ix),' i=',i,' j=',j,& -! ' tisfcin=',IPD_Data(nb)%Coupling%tisfcin_cpl(ix), & +!! ' tisfcin=',IPD_Data(nb)%Coupling%tisfcin_cpl(ix), & +! ' tisfcin=',IPD_Data(nb)%Sfcprop%tisfc(ix), & ! ' fice=',IPD_Data(nb)%Sfcprop%fice(ix) ! endif ! enddo diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index c2b64a544..ef569e83a 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -431,8 +431,8 @@ module GFS_typedefs real (kind=kind_phys), pointer :: dtsfcin_cpl(:) => null() !< aoi_fld%dtsfcin(item,lan) real (kind=kind_phys), pointer :: dqsfcin_cpl(:) => null() !< aoi_fld%dqsfcin(item,lan) real (kind=kind_phys), pointer :: ulwsfcin_cpl(:)=> null() !< aoi_fld%ulwsfcin(item,lan) - real (kind=kind_phys), pointer :: tseain_cpl(:) => null() !< aoi_fld%tseain(item,lan) - real (kind=kind_phys), pointer :: tisfcin_cpl(:) => null() !< aoi_fld%tisfcin(item,lan) +! real (kind=kind_phys), pointer :: tseain_cpl(:) => null() !< aoi_fld%tseain(item,lan) +! real (kind=kind_phys), pointer :: tisfcin_cpl(:) => null() !< aoi_fld%tisfcin(item,lan) real (kind=kind_phys), pointer :: ficein_cpl(:) => null() !< aoi_fld%ficein(item,lan) real (kind=kind_phys), pointer :: hicein_cpl(:) => null() !< aoi_fld%hicein(item,lan) real (kind=kind_phys), pointer :: hsnoin_cpl(:) => null() !< aoi_fld%hsnoin(item,lan) @@ -2561,8 +2561,8 @@ subroutine coupling_create (Coupling, IM, Model) allocate (Coupling%dtsfcin_cpl (IM)) allocate (Coupling%dqsfcin_cpl (IM)) allocate (Coupling%ulwsfcin_cpl (IM)) - allocate (Coupling%tseain_cpl (IM)) - allocate (Coupling%tisfcin_cpl (IM)) +! allocate (Coupling%tseain_cpl (IM)) +! allocate (Coupling%tisfcin_cpl (IM)) allocate (Coupling%ficein_cpl (IM)) allocate (Coupling%hicein_cpl (IM)) allocate (Coupling%hsnoin_cpl (IM)) @@ -2573,8 +2573,8 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%dtsfcin_cpl = clear_val Coupling%dqsfcin_cpl = clear_val Coupling%ulwsfcin_cpl = clear_val - Coupling%tseain_cpl = clear_val - Coupling%tisfcin_cpl = clear_val +! Coupling%tseain_cpl = clear_val +! Coupling%tisfcin_cpl = clear_val Coupling%ficein_cpl = clear_val Coupling%hicein_cpl = clear_val Coupling%hsnoin_cpl = clear_val From 56a411196918229d76cc81a1bd171ab1ca4edee8 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 10 May 2020 01:09:49 +0000 Subject: [PATCH 49/91] merged with fv3atm develop, tested the coupled model with nsst model turned on, removed a few unneeded arrays and some other updates --- atmos_model.F90 | 50 +++-- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 1 - gfsphysics/GFS_layer/GFS_typedefs.F90 | 22 +-- gfsphysics/physics/GFS_debug.F90 | 14 +- gfsphysics/physics/module_nst_model.f90 | 2 +- io/FV3GFS_io.F90 | 208 +++++++++++--------- 7 files changed, 164 insertions(+), 135 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index c9aa82474..97618c3ad 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -323,13 +323,19 @@ subroutine update_atmos_radiation_physics (Atmos) endif !--- if coupled, assign coupled fields + if( IPD_Control%cplflx .or. IPD_Control%cplwav ) then -! print *,'in atmos_model,nblks=',Atm_block%nblks -! print *,'in atmos_model,IPD_Data size=',size(IPD_Data) -! print *,'in atmos_model,tsfc(1)=',IPD_Data(1)%sfcprop%tsfc(1) -! print *,'in atmos_model, tsfc size=',size(IPD_Data(1)%sfcprop%tsfc) + +! if (mpp_pe() == mpp_root_pe() .and. debug) then +! print *,'in atmos_model,nblks=',Atm_block%nblks +! print *,'in atmos_model,IPD_Data size=',size(IPD_Data) +! print *,'in atmos_model,tsfc(1)=',IPD_Data(1)%sfcprop%tsfc(1) +! print *,'in atmos_model, tsfc size=',size(IPD_Data(1)%sfcprop%tsfc) +! endif + call assign_importdata(rc) -! print *,'in atmos_model, after assign_importdata, rc=',rc + +! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in atmos_model, after assign_importdata, rc=',rc endif call mpp_clock_end(setupClock) @@ -1629,6 +1635,7 @@ subroutine assign_importdata(rc) found = .false. + isFieldCreated = ESMF_FieldIsCreated(importFields(n), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1639,6 +1646,8 @@ subroutine assign_importdata(rc) name=impfield_name, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return +! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplIMP,atmos gets ',' n=',n,trim(impfield_name) + if ( dimCount == 2) then if ( datatype == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(importFields(n),farrayPtr=datar82d,localDE=0, rc=rc) @@ -1687,7 +1696,7 @@ subroutine assign_importdata(rc) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then tem = 100.0_IPD_kind_phys * max(zero, min(0.1_IPD_kind_phys, datar8(i,j))) - IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem +! IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem IPD_Data(nb)%Sfcprop%zorlo(ix) = tem endif @@ -1721,9 +1730,6 @@ subroutine assign_importdata(rc) fldname = 'sea_surface_temperature' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) -! if (mpp_pe() == mpp_root_pe() .and. debug) print *,' for sst', & -! ' fldname=',fldname,' findex=',findex,' importFieldsValid=',importFieldsValid(findex) - if (importFieldsValid(findex)) then !$omp parallel do default(shared) private(i,j,nb,ix) do j=jsc,jec @@ -1752,18 +1758,19 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - IPD_Data(nb)%Coupling%ficein_cpl(ix) = zero + + IPD_Data(nb)%Sfcprop%fice(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = IPD_Data(nb)%Sfcprop%slmsk(ix) ofrac = IPD_Data(nb)%Sfcprop%oceanfrac(ix) if (ofrac > zero) then - IPD_Data(nb)%Coupling%ficein_cpl(ix) = max(zero, min(one, datar8(i,j)/ofrac)) !LHS: ice frac wrt water area - if (IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then - if (IPD_Data(nb)%Coupling%ficein_cpl(ix) > one-epsln) IPD_Data(nb)%Coupling%ficein_cpl(ix) = one + IPD_Data(nb)%Sfcprop%fice(ix) = max(zero, min(one, datar8(i,j)/ofrac)) !LHS: ice frac wrt water area + if (IPD_Data(nb)%Sfcprop%fice(ix) >= IPD_control%min_seaice) then + if (IPD_Data(nb)%Sfcprop%fice(ix) > one-epsln) IPD_Data(nb)%Sfcprop%fice(ix) = one ! if (abs(one-ofrac) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4.0_IPD_kind_phys else - IPD_Data(nb)%Coupling%ficein_cpl(ix) = zero + IPD_Data(nb)%Sfcprop%fice(ix) = zero if (abs(one-ofrac) < epsln) then IPD_Data(nb)%Sfcprop%slmsk(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero @@ -1895,7 +1902,8 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%hicein_cpl(ix) = datar8(i,j) +! IPD_Data(nb)%Coupling%hicein_cpl(ix) = datar8(i,j) + IPD_Data(nb)%Sfcprop%hice(ix) = datar8(i,j) endif enddo enddo @@ -1938,13 +1946,17 @@ subroutine assign_importdata(rc) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then !if it is ocean or ice get surface temperature from mediator - if(IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then + if (IPD_Data(nb)%Sfcprop%fice(ix) >= IPD_control%min_seaice) then + +! if(IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then ! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tisfcin_cpl(ix) - IPD_Data(nb)%Sfcprop%fice(ix) = IPD_Data(nb)%Coupling%ficein_cpl(ix) - IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) +! IPD_Data(nb)%Sfcprop%fice(ix) = IPD_Data(nb)%Coupling%ficein_cpl(ix) +! IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) ! IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) + IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) & - / max(0.01_IPD_kind_phys, IPD_Data(nb)%Coupling%ficein_cpl(ix)) + / max(0.01_IPD_kind_phys, IPD_Data(nb)%Sfcprop%fice(ix)) +! / max(0.01_IPD_kind_phys, IPD_Data(nb)%Coupling%ficein_cpl(ix)) else ! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Sfcprop%tsfco(ix) diff --git a/ccpp/physics b/ccpp/physics index 2b3448869..513cb29b7 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 2b344886933a3c9978d992e41271bc3caef9eaf8 +Subproject commit 513cb29b7572d3246b6cf44e7c857ddfdb23c13f diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 708e8c6e8..1e9f42b93 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -2104,7 +2104,6 @@ subroutine GFS_physics_driver & k = 2 stress(i) = stress3(i,2) ! Sfcprop%tprcp(i) = fice(i)*tprcp3(i,2) + (one-fice(i))*tprcp3(i,3) - if(Model%cplflx)Sfcprop%tsfcl(i) = tsfc3(i,2) ! for restart repro comparisons endif Sfcprop%zorl(i) = zorl3(i,k) cd(i) = cd3(i,k) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index ef569e83a..d70c0cc8e 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -433,11 +433,11 @@ module GFS_typedefs real (kind=kind_phys), pointer :: ulwsfcin_cpl(:)=> null() !< aoi_fld%ulwsfcin(item,lan) ! real (kind=kind_phys), pointer :: tseain_cpl(:) => null() !< aoi_fld%tseain(item,lan) ! real (kind=kind_phys), pointer :: tisfcin_cpl(:) => null() !< aoi_fld%tisfcin(item,lan) - real (kind=kind_phys), pointer :: ficein_cpl(:) => null() !< aoi_fld%ficein(item,lan) - real (kind=kind_phys), pointer :: hicein_cpl(:) => null() !< aoi_fld%hicein(item,lan) +! real (kind=kind_phys), pointer :: ficein_cpl(:) => null() !< aoi_fld%ficein(item,lan) +! real (kind=kind_phys), pointer :: hicein_cpl(:) => null() !< aoi_fld%hicein(item,lan) real (kind=kind_phys), pointer :: hsnoin_cpl(:) => null() !< aoi_fld%hsnoin(item,lan) !--- only variable needed for cplwav2atm=.TRUE. - real (kind=kind_phys), pointer :: zorlwav_cpl(:) => null() !< roughness length from wave model +! real (kind=kind_phys), pointer :: zorlwav_cpl(:) => null() !< roughness length from wave model !--- also needed for ice/ocn coupling - Xingren real (kind=kind_phys), pointer :: slimskin_cpl(:)=> null() !< aoi_fld%slimskin(item,lan) @@ -2546,12 +2546,12 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%v10mi_cpl = clear_val endif - if (Model%cplwav2atm) then +! if (Model%cplwav2atm) then !--- incoming quantities - allocate (Coupling%zorlwav_cpl (IM)) +! allocate (Coupling%zorlwav_cpl (IM)) - Coupling%zorlwav_cpl = clear_val - end if +! Coupling%zorlwav_cpl = clear_val +! end if if (Model%cplflx) then !--- incoming quantities @@ -2563,8 +2563,8 @@ subroutine coupling_create (Coupling, IM, Model) allocate (Coupling%ulwsfcin_cpl (IM)) ! allocate (Coupling%tseain_cpl (IM)) ! allocate (Coupling%tisfcin_cpl (IM)) - allocate (Coupling%ficein_cpl (IM)) - allocate (Coupling%hicein_cpl (IM)) +! allocate (Coupling%ficein_cpl (IM)) +! allocate (Coupling%hicein_cpl (IM)) allocate (Coupling%hsnoin_cpl (IM)) Coupling%slimskin_cpl = clear_val @@ -2575,8 +2575,8 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%ulwsfcin_cpl = clear_val ! Coupling%tseain_cpl = clear_val ! Coupling%tisfcin_cpl = clear_val - Coupling%ficein_cpl = clear_val - Coupling%hicein_cpl = clear_val +! Coupling%ficein_cpl = clear_val +! Coupling%hicein_cpl = clear_val Coupling%hsnoin_cpl = clear_val !--- accumulated quantities diff --git a/gfsphysics/physics/GFS_debug.F90 b/gfsphysics/physics/GFS_debug.F90 index c0b24ca97..f4edecfaf 100644 --- a/gfsphysics/physics/GFS_debug.F90 +++ b/gfsphysics/physics/GFS_debug.F90 @@ -394,9 +394,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Coupling%rain_cpl', Coupling%rain_cpl) call print_var(mpirank,omprank, blkno, 'Coupling%snow_cpl', Coupling%snow_cpl) end if - if (Model%cplwav2atm) then - call print_var(mpirank,omprank, blkno, 'Coupling%zorlwav_cpl' , Coupling%zorlwav_cpl ) - end if +! if (Model%cplwav2atm) then +! call print_var(mpirank,omprank, blkno, 'Coupling%zorlwav_cpl' , Coupling%zorlwav_cpl ) +! end if if (Model%cplflx) then call print_var(mpirank,omprank, blkno, 'Coupling%oro_cpl' , Coupling%oro_cpl ) call print_var(mpirank,omprank, blkno, 'Coupling%slmsk_cpl' , Coupling%slmsk_cpl ) @@ -406,10 +406,10 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Coupling%dtsfcin_cpl ', Coupling%dtsfcin_cpl ) call print_var(mpirank,omprank, blkno, 'Coupling%dqsfcin_cpl ', Coupling%dqsfcin_cpl ) call print_var(mpirank,omprank, blkno, 'Coupling%ulwsfcin_cpl', Coupling%ulwsfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%tseain_cpl ', Coupling%tseain_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%tisfcin_cpl ', Coupling%tisfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%ficein_cpl ', Coupling%ficein_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%hicein_cpl ', Coupling%hicein_cpl ) +! call print_var(mpirank,omprank, blkno, 'Coupling%tseain_cpl ', Coupling%tseain_cpl ) +! call print_var(mpirank,omprank, blkno, 'Coupling%tisfcin_cpl ', Coupling%tisfcin_cpl ) +! call print_var(mpirank,omprank, blkno, 'Coupling%ficein_cpl ', Coupling%ficein_cpl ) +! call print_var(mpirank,omprank, blkno, 'Coupling%hicein_cpl ', Coupling%hicein_cpl ) call print_var(mpirank,omprank, blkno, 'Coupling%hsnoin_cpl ', Coupling%hsnoin_cpl ) call print_var(mpirank,omprank, blkno, 'Coupling%dusfc_cpl ', Coupling%dusfc_cpl ) call print_var(mpirank,omprank, blkno, 'Coupling%dvsfc_cpl ', Coupling%dvsfc_cpl ) diff --git a/gfsphysics/physics/module_nst_model.f90 b/gfsphysics/physics/module_nst_model.f90 index f2b05c110..7154489f6 100644 --- a/gfsphysics/physics/module_nst_model.f90 +++ b/gfsphysics/physics/module_nst_model.f90 @@ -846,7 +846,7 @@ subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q zcsq = z_c * z_c a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4) - if ( hb > 0.0 ) then + if ( hb > 0.0 .and. zcsq > 0.0 .and. alpha > 0.0) then bc1 = zcsq * (q_ts+cc3*hl_ts) bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq) zc_ts = bc1/bc2 diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 7574f072b..5b67a4497 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -86,6 +86,7 @@ module FV3GFS_io_mod real(kind=kind_phys) :: zhour ! + integer, parameter :: r8 = kind_phys integer :: tot_diag_idx = 0 integer :: total_outputlevel = 0 integer :: isco,ieco,jsco,jeco,levo,num_axes_phys @@ -102,10 +103,10 @@ module FV3GFS_io_mod logical :: uwork_set = .false. character(128) :: uwindname integer, parameter, public :: DIAG_SIZE = 500 - real, parameter :: missing_value = 9.99e20 - real, parameter:: stndrd_atmos_ps = 101325. - real, parameter:: stndrd_atmos_lapse = 0.0065 - real, parameter:: drythresh = 1.e-4 + real, parameter :: missing_value = 9.99e20_r8 + real, parameter:: stndrd_atmos_ps = 101325.0_r8 + real, parameter:: stndrd_atmos_lapse = 0.0065_r8 + real, parameter:: drythresh = 1.e-4_r8, zero = 0.0_r8, one = 1.0_r8 !--- miscellaneous other variables logical :: use_wrtgridcomp_output = .FALSE. @@ -202,9 +203,9 @@ subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) allocate (temp3d(isc:iec,jsc:jec,1:lev,14+Model%ntot3d+2*ntr)) allocate (temp3dlevsp1(isc:iec,jsc:jec,1:lev+1,3)) - temp2d = 0. - temp3d = 0. - temp3dlevsp1 = 0. + temp2d = zero + temp3d = zero + temp3dlevsp1 = zero do j=jsc,jec do i=isc,iec @@ -378,16 +379,16 @@ subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) endif if (Model%nstf_name(1) > 0) then - temp2d(i,j,idx_opt) = IPD_Data(nb)%Sfcprop%tref(ix) - temp2d(i,j,idx_opt+1) = IPD_Data(nb)%Sfcprop%z_c(ix) - temp2d(i,j,idx_opt+2) = IPD_Data(nb)%Sfcprop%c_0(ix) - temp2d(i,j,idx_opt+3) = IPD_Data(nb)%Sfcprop%c_d(ix) - temp2d(i,j,idx_opt+4) = IPD_Data(nb)%Sfcprop%w_0(ix) - temp2d(i,j,idx_opt+5) = IPD_Data(nb)%Sfcprop%w_d(ix) - temp2d(i,j,idx_opt+6) = IPD_Data(nb)%Sfcprop%xt(ix) - temp2d(i,j,idx_opt+7) = IPD_Data(nb)%Sfcprop%xs(ix) - temp2d(i,j,idx_opt+8) = IPD_Data(nb)%Sfcprop%xu(ix) - temp2d(i,j,idx_opt+9) = IPD_Data(nb)%Sfcprop%xz(ix) + temp2d(i,j,idx_opt ) = IPD_Data(nb)%Sfcprop%tref(ix) + temp2d(i,j,idx_opt+ 1) = IPD_Data(nb)%Sfcprop%z_c(ix) + temp2d(i,j,idx_opt+ 2) = IPD_Data(nb)%Sfcprop%c_0(ix) + temp2d(i,j,idx_opt+ 3) = IPD_Data(nb)%Sfcprop%c_d(ix) + temp2d(i,j,idx_opt+ 4) = IPD_Data(nb)%Sfcprop%w_0(ix) + temp2d(i,j,idx_opt+ 5) = IPD_Data(nb)%Sfcprop%w_d(ix) + temp2d(i,j,idx_opt+ 6) = IPD_Data(nb)%Sfcprop%xt(ix) + temp2d(i,j,idx_opt+ 7) = IPD_Data(nb)%Sfcprop%xs(ix) + temp2d(i,j,idx_opt+ 8) = IPD_Data(nb)%Sfcprop%xu(ix) + temp2d(i,j,idx_opt+ 9) = IPD_Data(nb)%Sfcprop%xz(ix) temp2d(i,j,idx_opt+10) = IPD_Data(nb)%Sfcprop%zm(ix) temp2d(i,j,idx_opt+11) = IPD_Data(nb)%Sfcprop%xtts(ix) temp2d(i,j,idx_opt+12) = IPD_Data(nb)%Sfcprop%xzts(ix) @@ -512,8 +513,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) real(kind=kind_phys), dimension(-2:4) :: dzsnso real(kind=kind_phys), dimension(4), save :: zsoil,dzs - data dzs /0.1,0.3,0.6,1.0/ - data zsoil /-0.1,-0.4,-1.0,-2.0/ + data dzs /0.1_r8,0.3_r8,0.6_r8,1.0_r8/ + data zsoil /-0.1_r8,-0.4_r8,-1.0_r8,-2.0_r8/ if (Model%cplflx) then ! needs more variables @@ -670,16 +671,16 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp)) allocate(sfc_var3(nx,ny,Model%lsoil,nvar_s3)) #endif - sfc_var2 = -9999._kind_phys - sfc_var3 = -9999._kind_phys + sfc_var2 = -9999.0_r8 + sfc_var3 = -9999.0_r8 ! if (Model%lsm == Model%lsm_noahmp) then allocate(sfc_var3sn(nx,ny,-2:0,4:6)) allocate(sfc_var3eq(nx,ny,1:4,7:7)) allocate(sfc_var3zn(nx,ny,-2:4,8:8)) - sfc_var3sn = -9999._kind_phys - sfc_var3eq = -9999._kind_phys - sfc_var3zn = -9999._kind_phys + sfc_var3sn = -9999.0_r8 + sfc_var3eq = -9999.0_r8 + sfc_var3zn = -9999.0_r8 end if !--- names of the 2D variables to save @@ -894,7 +895,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !coldstart(sfcfile doesn't include noah mp fields) or not if (Model%lsm == Model%lsm_noahmp) then - sfc_var2(1,1,nvar_s2m+19) = -66666. + sfc_var2(1,1,nvar_s2m+19) = -66666.0_r8 endif !--- read the surface restart/data @@ -951,54 +952,71 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if(Model%frac_grid) then ! obtain slmsk from landfrac !! next 5 lines are temporary till lake model is available - if (Sfcprop(nb)%lakefrac(ix) > 0.0) then + if (Sfcprop(nb)%lakefrac(ix) > zero) then Sfcprop(nb)%lakefrac(ix) = nint(Sfcprop(nb)%lakefrac(ix)) - Sfcprop(nb)%landfrac(ix) = 1.-Sfcprop(nb)%lakefrac(ix) - if (Sfcprop(nb)%lakefrac(ix) == 0) Sfcprop(nb)%fice(ix)=0. + Sfcprop(nb)%landfrac(ix) = one - Sfcprop(nb)%lakefrac(ix) + if (Sfcprop(nb)%lakefrac(ix) == zero) Sfcprop(nb)%fice(ix) = zero end if Sfcprop(nb)%slmsk(ix) = ceiling(Sfcprop(nb)%landfrac(ix)) - if (Sfcprop(nb)%fice(ix) > 0. .and. Sfcprop(nb)%landfrac(ix)==0.) Sfcprop(nb)%slmsk(ix) = 2 ! land dominates ice if co-exist + if (Sfcprop(nb)%fice(ix) > zero .and. Sfcprop(nb)%landfrac(ix) == zero) Sfcprop(nb)%slmsk(ix) = 2 ! land dominates ice if co-exist else ! obtain landfrac from slmsk - if (Sfcprop(nb)%slmsk(ix) > 1.9) then - Sfcprop(nb)%landfrac(ix) = 0.0 + if (Sfcprop(nb)%slmsk(ix) > 1.9_r8) then + Sfcprop(nb)%landfrac(ix) = zero else Sfcprop(nb)%landfrac(ix) = Sfcprop(nb)%slmsk(ix) endif end if - if (Sfcprop(nb)%lakefrac(ix) > 0.0) then - Sfcprop(nb)%oceanfrac(ix) = 0.0 ! lake & ocean don't coexist in a cell - if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) Sfcprop(nb)%fice(ix) = 0. + if (Sfcprop(nb)%lakefrac(ix) > zero) then + Sfcprop(nb)%oceanfrac(ix) = zero ! lake & ocean don't coexist in a cell + if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) Sfcprop(nb)%fice(ix) = zero else - Sfcprop(nb)%oceanfrac(ix) = 1.0 - Sfcprop(nb)%landfrac(ix) - if (Sfcprop(nb)%fice(ix) < Model%min_seaice) Sfcprop(nb)%fice(ix) = 0. + Sfcprop(nb)%oceanfrac(ix) = one - Sfcprop(nb)%landfrac(ix) + if (Sfcprop(nb)%fice(ix) < Model%min_seaice) Sfcprop(nb)%fice(ix) = zero endif ! !--- NSSTM variables - if ((Model%nstf_name(1) > 0) .and. (Model%nstf_name(2) == 1)) then + if (Model%nstf_name(1) > 0) then + if (Model%nstf_name(2) == 1) then ! nsst spinup !--- nsstm tref - Sfcprop(nb)%tref(ix) = Sfcprop(nb)%tsfco(ix) - Sfcprop(nb)%xz(ix) = 30.0d0 - endif - if ((Model%nstf_name(1) > 0) .and. (Model%nstf_name(2) == 0)) then - Sfcprop(nb)%tref(ix) = sfc_var2(i,j,nvar_s2m+1) !--- nsstm tref - Sfcprop(nb)%z_c(ix) = sfc_var2(i,j,nvar_s2m+2) !--- nsstm z_c - Sfcprop(nb)%c_0(ix) = sfc_var2(i,j,nvar_s2m+3) !--- nsstm c_0 - Sfcprop(nb)%c_d(ix) = sfc_var2(i,j,nvar_s2m+4) !--- nsstm c_d - Sfcprop(nb)%w_0(ix) = sfc_var2(i,j,nvar_s2m+5) !--- nsstm w_0 - Sfcprop(nb)%w_d(ix) = sfc_var2(i,j,nvar_s2m+6) !--- nsstm w_d - Sfcprop(nb)%xt(ix) = sfc_var2(i,j,nvar_s2m+7) !--- nsstm xt - Sfcprop(nb)%xs(ix) = sfc_var2(i,j,nvar_s2m+8) !--- nsstm xs - Sfcprop(nb)%xu(ix) = sfc_var2(i,j,nvar_s2m+9) !--- nsstm xu - Sfcprop(nb)%xv(ix) = sfc_var2(i,j,nvar_s2m+10) !--- nsstm xv - Sfcprop(nb)%xz(ix) = sfc_var2(i,j,nvar_s2m+11) !--- nsstm xz - Sfcprop(nb)%zm(ix) = sfc_var2(i,j,nvar_s2m+12) !--- nsstm zm - Sfcprop(nb)%xtts(ix) = sfc_var2(i,j,nvar_s2m+13) !--- nsstm xtts - Sfcprop(nb)%xzts(ix) = sfc_var2(i,j,nvar_s2m+14) !--- nsstm xzts - Sfcprop(nb)%d_conv(ix) = sfc_var2(i,j,nvar_s2m+15) !--- nsstm d_conv - Sfcprop(nb)%ifd(ix) = sfc_var2(i,j,nvar_s2m+16) !--- nsstm ifd - Sfcprop(nb)%dt_cool(ix) = sfc_var2(i,j,nvar_s2m+17) !--- nsstm dt_cool - Sfcprop(nb)%qrain(ix) = sfc_var2(i,j,nvar_s2m+18) !--- nsstm qrain + Sfcprop(nb)%tref(ix) = Sfcprop(nb)%tsfco(ix) + Sfcprop(nb)%z_c(ix) = zero + Sfcprop(nb)%c_0(ix) = zero + Sfcprop(nb)%c_d(ix) = zero + Sfcprop(nb)%w_0(ix) = zero + Sfcprop(nb)%w_d(ix) = zero + Sfcprop(nb)%xt(ix) = zero + Sfcprop(nb)%xs(ix) = zero + Sfcprop(nb)%xu(ix) = zero + Sfcprop(nb)%xv(ix) = zero + Sfcprop(nb)%xz(ix) = 30.0_r8 + Sfcprop(nb)%zm(ix) = zero + Sfcprop(nb)%xtts(ix) = zero + Sfcprop(nb)%xzts(ix) = zero + Sfcprop(nb)%d_conv(ix) = zero + Sfcprop(nb)%ifd(ix) = zero + Sfcprop(nb)%dt_cool(ix) = zero + Sfcprop(nb)%qrain(ix) = zero + elseif (Model%nstf_name(2) == 0) then ! nsst restart + Sfcprop(nb)%tref(ix) = sfc_var2(i,j,nvar_s2m+1) !--- nsstm tref + Sfcprop(nb)%z_c(ix) = sfc_var2(i,j,nvar_s2m+2) !--- nsstm z_c + Sfcprop(nb)%c_0(ix) = sfc_var2(i,j,nvar_s2m+3) !--- nsstm c_0 + Sfcprop(nb)%c_d(ix) = sfc_var2(i,j,nvar_s2m+4) !--- nsstm c_d + Sfcprop(nb)%w_0(ix) = sfc_var2(i,j,nvar_s2m+5) !--- nsstm w_0 + Sfcprop(nb)%w_d(ix) = sfc_var2(i,j,nvar_s2m+6) !--- nsstm w_d + Sfcprop(nb)%xt(ix) = sfc_var2(i,j,nvar_s2m+7) !--- nsstm xt + Sfcprop(nb)%xs(ix) = sfc_var2(i,j,nvar_s2m+8) !--- nsstm xs + Sfcprop(nb)%xu(ix) = sfc_var2(i,j,nvar_s2m+9) !--- nsstm xu + Sfcprop(nb)%xv(ix) = sfc_var2(i,j,nvar_s2m+10) !--- nsstm xv + Sfcprop(nb)%xz(ix) = sfc_var2(i,j,nvar_s2m+11) !--- nsstm xz + Sfcprop(nb)%zm(ix) = sfc_var2(i,j,nvar_s2m+12) !--- nsstm zm + Sfcprop(nb)%xtts(ix) = sfc_var2(i,j,nvar_s2m+13) !--- nsstm xtts + Sfcprop(nb)%xzts(ix) = sfc_var2(i,j,nvar_s2m+14) !--- nsstm xzts + Sfcprop(nb)%d_conv(ix) = sfc_var2(i,j,nvar_s2m+15) !--- nsstm d_conv + Sfcprop(nb)%ifd(ix) = sfc_var2(i,j,nvar_s2m+16) !--- nsstm ifd + Sfcprop(nb)%dt_cool(ix) = sfc_var2(i,j,nvar_s2m+17) !--- nsstm dt_cool + Sfcprop(nb)%qrain(ix) = sfc_var2(i,j,nvar_s2m+18) !--- nsstm qrain + endif endif #ifdef CCPP if (Model%lsm == Model%lsm_ruc .and. warm_start) then @@ -1140,15 +1158,15 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !--- code taken directly from read_fix.f do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) - Sfcprop(nb)%sncovr(ix) = 0.0 + Sfcprop(nb)%sncovr(ix) = zero if (Sfcprop(nb)%landfrac(ix) >= drythresh .or. Sfcprop(nb)%fice(ix) >= Model%min_seaice) then vegtyp = Sfcprop(nb)%vtype(ix) if (vegtyp == 0) vegtyp = 7 - rsnow = 0.001*Sfcprop(nb)%weasd(ix)/snupx(vegtyp) - if (0.001*Sfcprop(nb)%weasd(ix) < snupx(vegtyp)) then - Sfcprop(nb)%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + rsnow = 0.001_r8*Sfcprop(nb)%weasd(ix)/snupx(vegtyp) + if (0.001_r8*Sfcprop(nb)%weasd(ix) < snupx(vegtyp)) then + Sfcprop(nb)%sncovr(ix) = one - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) else - Sfcprop(nb)%sncovr(ix) = 1.0 + Sfcprop(nb)%sncovr(ix) = one endif endif enddo @@ -1184,10 +1202,10 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) tem = (1.-Sfcprop(nb)%landfrac(ix)) * Sfcprop(nb)%fice(ix) ! tem = ice fraction wrt whole cell Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) * Sfcprop(nb)%landfrac(ix) & + Sfcprop(nb)%zorll(ix) * tem & !zorl ice = zorl land - + Sfcprop(nb)%zorlo(ix) * (1.-Sfcprop(nb)%landfrac(ix)-tem) + + Sfcprop(nb)%zorlo(ix) * (one-Sfcprop(nb)%landfrac(ix)-tem) Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) * Sfcprop(nb)%landfrac(ix) & + Sfcprop(nb)%tisfc(ix) * tem & - + Sfcprop(nb)%tsfco(ix) * (1.-Sfcprop(nb)%landfrac(ix)-tem) + + Sfcprop(nb)%tsfco(ix) * (one-Sfcprop(nb)%landfrac(ix)-tem) enddo enddo else @@ -1574,16 +1592,16 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta allocate(sfc_var2(nx,ny,nvar2m+nvar2o+nvar2mp)) allocate(sfc_var3(nx,ny,Model%lsoil,nvar3)) #endif - sfc_var2 = -9999._kind_phys - sfc_var3 = -9999._kind_phys + sfc_var2 = -9999.0_r8 + sfc_var3 = -9999.0_r8 if (Model%lsm == Model%lsm_noahmp) then allocate(sfc_var3sn(nx,ny,-2:0,4:6)) allocate(sfc_var3eq(nx,ny,1:4,7:7)) allocate(sfc_var3zn(nx,ny,-2:4,8:8)) - sfc_var3sn = -9999._kind_phys - sfc_var3eq = -9999._kind_phys - sfc_var3zn = -9999._kind_phys + sfc_var3sn = -9999.0_r8 + sfc_var3eq = -9999.0_r8 + sfc_var3zn = -9999.0_r8 endif @@ -1831,15 +1849,15 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta end if !--- NSSTM variables if (Model%nstf_name(1) > 0) then - sfc_var2(i,j,nvar2m+1) = Sfcprop(nb)%tref(ix) !--- nsstm tref - sfc_var2(i,j,nvar2m+2) = Sfcprop(nb)%z_c(ix) !--- nsstm z_c - sfc_var2(i,j,nvar2m+3) = Sfcprop(nb)%c_0(ix) !--- nsstm c_0 - sfc_var2(i,j,nvar2m+4) = Sfcprop(nb)%c_d(ix) !--- nsstm c_d - sfc_var2(i,j,nvar2m+5) = Sfcprop(nb)%w_0(ix) !--- nsstm w_0 - sfc_var2(i,j,nvar2m+6) = Sfcprop(nb)%w_d(ix) !--- nsstm w_d - sfc_var2(i,j,nvar2m+7) = Sfcprop(nb)%xt(ix) !--- nsstm xt - sfc_var2(i,j,nvar2m+8) = Sfcprop(nb)%xs(ix) !--- nsstm xs - sfc_var2(i,j,nvar2m+9) = Sfcprop(nb)%xu(ix) !--- nsstm xu + sfc_var2(i,j,nvar2m+1) = Sfcprop(nb)%tref(ix) !--- nsstm tref + sfc_var2(i,j,nvar2m+2) = Sfcprop(nb)%z_c(ix) !--- nsstm z_c + sfc_var2(i,j,nvar2m+3) = Sfcprop(nb)%c_0(ix) !--- nsstm c_0 + sfc_var2(i,j,nvar2m+4) = Sfcprop(nb)%c_d(ix) !--- nsstm c_d + sfc_var2(i,j,nvar2m+5) = Sfcprop(nb)%w_0(ix) !--- nsstm w_0 + sfc_var2(i,j,nvar2m+6) = Sfcprop(nb)%w_d(ix) !--- nsstm w_d + sfc_var2(i,j,nvar2m+7) = Sfcprop(nb)%xt(ix) !--- nsstm xt + sfc_var2(i,j,nvar2m+8) = Sfcprop(nb)%xs(ix) !--- nsstm xs + sfc_var2(i,j,nvar2m+9) = Sfcprop(nb)%xu(ix) !--- nsstm xu sfc_var2(i,j,nvar2m+10) = Sfcprop(nb)%xv(ix) !--- nsstm xv sfc_var2(i,j,nvar2m+11) = Sfcprop(nb)%xz(ix) !--- nsstm xz sfc_var2(i,j,nvar2m+12) = Sfcprop(nb)%zm(ix) !--- nsstm zm @@ -2015,8 +2033,8 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) if (.not. allocated(phy_var2)) then allocate (phy_var2(nx,ny,nvar2d)) allocate (phy_var3(nx,ny,npz,nvar3d)) - phy_var2 = 0.0_kind_phys - phy_var3 = 0.0_kind_phys + phy_var2 = zero + phy_var3 = zero do num = 1,nvar2d var2_p => phy_var2(:,:,num) @@ -2060,7 +2078,7 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) do ix = 1, Atm_block%blksz(nb) i = Atm_block%index(nb)%ii(ix) - isc + 1 j = Atm_block%index(nb)%jj(ix) - jsc + 1 - IPD_Restart%data(nb,num)%var2p(ix) = 0. + IPD_Restart%data(nb,num)%var2p(ix) = zero enddo enddo enddo @@ -2120,8 +2138,8 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta if (.not. allocated(phy_var2)) then allocate (phy_var2(nx,ny,nvar2d)) allocate (phy_var3(nx,ny,npz,nvar3d)) - phy_var2 = 0.0_kind_phys - phy_var3 = 0.0_kind_phys + phy_var2 = zero + phy_var3 = zero do num = 1,nvar2d var2_p => phy_var2(:,:,num) @@ -2273,9 +2291,9 @@ subroutine fv3gfs_diag_register(Diag, Time, Atm_block, Model, xlon, xlat, axes) allocate(buffer_phys_bl(isco:ieco,jsco:jeco,nrgst_bl)) allocate(buffer_phys_nb(isco:ieco,jsco:jeco,nrgst_nb)) allocate(buffer_phys_windvect(3,isco:ieco,jsco:jeco,nrgst_vctbl)) - buffer_phys_bl = 0. - buffer_phys_nb = 0. - buffer_phys_windvect = 0. + buffer_phys_bl = zero + buffer_phys_nb = zero + buffer_phys_windvect = zero if(mpp_pe() == mpp_root_pe()) print *,'in fv3gfs_diag_register, nrgst_bl=',nrgst_bl,' nrgst_nb=',nrgst_nb, & ' nrgst_vctbl=',nrgst_vctbl, 'isco=',isco,ieco,'jsco=',jsco,jeco,' num_axes_phys=', num_axes_phys @@ -2316,11 +2334,11 @@ subroutine fv3gfs_diag_output(time, diag, atm_block, nx, ny, levs, ntcw, ntoz, & logical :: used nblks = atm_block%nblks - rdt = 1.0d0/dt - rtime_int = 1.0d0/time_int - rtime_intfull = 1.0d0/time_intfull - rtime_radsw = 1.0d0/time_radsw - rtime_radlw = 1.0d0/time_radlw + rdt = one/dt + rtime_int = one/time_int + rtime_intfull = one/time_intfull + rtime_radsw = one/time_radsw + rtime_radlw = one/time_radlw isc = atm_block%isc jsc = atm_block%jsc @@ -2619,7 +2637,7 @@ subroutine store_data(id, work, Time, idx, intpl_method, fldname) enddo enddo endif - uwork = 0.0 + uwork = zero uwindname = '' uwork_set = .false. endif @@ -2720,7 +2738,7 @@ subroutine store_data3D(id, work, Time, idx, intpl_method, fldname) enddo deallocate (sinlon, coslon, sinlat, coslat) endif - uwork3d = 0. + uwork3d = zero uwindname = '' uwork_set = .false. endif From 29a132990d7866ffed6dd3a1a6be45bf191a8b18 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 10 May 2020 01:11:32 +0000 Subject: [PATCH 50/91] Adding a new suite suite_FV3_GFS_cpld_rasmgshocnsst.xml --- .../suite_FV3_GFS_cpld_rasmgshocnsst.xml | 90 +++++++++++++++++++ 1 file changed, 90 insertions(+) create mode 100644 ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml diff --git a/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml new file mode 100644 index 000000000..5b3b63528 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml @@ -0,0 +1,90 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + lsm_noah + sfc_nst_pre + sfc_nst + sfc_nst_post + sfc_cice + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + moninshoc + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + shoc + GFS_DCNV_generic_pre + GFS_suite_interstitial_5 + rascnv + GFS_DCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + m_micro_pre + m_micro + m_micro_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + From 04412367cf671ab6e757126f02078c13dd6d094e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 11 May 2020 18:46:48 +0000 Subject: [PATCH 51/91] updating submodules --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 513cb29b7..3cdcdaab7 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 513cb29b7572d3246b6cf44e7c857ddfdb23c13f +Subproject commit 3cdcdaab7261ffb212e0c36b6eeff34880429cb4 From 2e9d571c1f2275a10be2b87d1f427bd277f62ffc Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 18 May 2020 21:04:57 -0400 Subject: [PATCH 52/91] updating nst model when coupled with ocean for IPD --- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 27 +++-- gfsphysics/physics/module_nst_water_prop.f90 | 112 +++++++++---------- 3 files changed, 67 insertions(+), 74 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 3cdcdaab7..4c08f739c 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 3cdcdaab7261ffb212e0c36b6eeff34880429cb4 +Subproject commit 4c08f739c121af21483e832cd29b4f3d34c9361e diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 1e9f42b93..3e78990c3 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -59,7 +59,7 @@ module module_physics_driver real(kind=kind_phys), parameter :: con_p001= 0.001_kind_phys real(kind=kind_phys), parameter :: con_day = 86400.0_kind_phys real(kind=kind_phys), parameter :: rad2dg = 180.0_kind_phys/con_pi - real(kind=kind_phys), parameter :: omz1 = 10.0_kind_phys + real(kind=kind_phys), parameter :: omz1 = 2.0_kind_phys real(kind=kind_phys), parameter :: huge = zero !> GFS Physics Implementation Layer @@ -515,6 +515,7 @@ subroutine GFS_physics_driver & stress, t850, ep1d, gamt, gamq, sigmaf, & wind, work1, work2, work3, work4, runof, xmu, fm10, fh2, & tx1, tx2, tx3, tx4, ctei_r, evbs, evcw, trans, sbsno,& +! dnsst, tx1, tx2, tx3, tx4, ctei_r, evbs, evcw, trans, sbsno,& snowc, frland, adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, & adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, adjnirbmd, & adjnirdfd, adjvisbmd, adjvisdfd, xcosz, tseal, & @@ -1709,24 +1710,26 @@ subroutine GFS_physics_driver & endif enddo if (Model%cplflx) then ! apply only at ocean points - tem1 = half / omz1 + call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & + Sfcprop%z_c, wet, zero, omz1, im, 1, dtzm) do i=1,im if (wet(i) .and. Sfcprop%oceanfrac(i) > zero) then - tem2 = one / Sfcprop%xz(i) - dt_warm = (Sfcprop%xt(i)+Sfcprop%xt(i)) * tem2 - if ( Sfcprop%xz(i) > omz1) then - Sfcprop%tref(i) = tseal(i) - (one-half*omz1*tem2) * dt_warm & - + Sfcprop%z_c(i)*Sfcprop%dt_cool(i)*tem1 +! dnsst = tsfc3(i,3) - Sfcprop%tref(i) ! retrive/get difference of Ts and Tf + Sfcprop%tref(i) = Sfcprop%tsfco(i) - dtzm(i) ! update Tf with T1 and NSST T-Profile +! tsfc3(i,3) = max(271.2,Sfcprop%tref(i) + dnsst ! get Ts updated due to Tf update +! tseal(i) = tsfc3(i,3) + if (abs(Sfcprop%xz(i)) > zero) then + tem2 = one / Sfcprop%xz(i) else - Sfcprop%tref(i) = tseal(i) - (Sfcprop%xz(i)*dt_warm & - - Sfcprop%z_c(i)*Sfcprop%dt_cool(i))*tem1 + tem2 = zero endif - TSEAl(i) = Sfcprop%tref(i) + dt_warm - Sfcprop%dt_cool(i) -! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse - tsurf3(i,3) = TSEAl(i) + tseal(i) = Sfcprop%tref(i) + (Sfcprop%xt(i)+Sfcprop%xt(i)) * tem2 & + - Sfcprop%dt_cool(i) + tsurf3(i,3) = tseal(i) endif enddo endif + ! if (lprnt) write(0,*)' bef nst tseal=',tseal(ipr) & ! ,' tsfc3=',tsfc3(ipr,3),' tsurf3=',tsurf3(ipr,3),' tem=',tem !*## CCPP ## diff --git a/gfsphysics/physics/module_nst_water_prop.f90 b/gfsphysics/physics/module_nst_water_prop.f90 index 36a699ede..ffc7f4896 100644 --- a/gfsphysics/physics/module_nst_water_prop.f90 +++ b/gfsphysics/physics/module_nst_water_prop.f90 @@ -5,7 +5,7 @@ module module_nst_water_prop private public :: rhocoef,density,sw_rad,sw_rad_aw,sw_rad_sum,sw_rad_upper,sw_rad_upper_aw,sw_rad_skin,grv,solar_time_from_julian,compjd, & sw_ps_9b,sw_ps_9b_aw,get_dtzm_point,get_dtzm_2d - + ! interface sw_ps_9b module procedure sw_ps_9b @@ -37,7 +37,7 @@ module module_nst_water_prop subroutine rhocoef(t, s, rhoref, alpha, beta) ! ------------------------------------------------------ - ! compute thermal expansion coefficient (alpha) + ! compute thermal expansion coefficient (alpha) ! and saline contraction coefficient (beta) using ! the international equation of state of sea water ! (1980). ref: pond and pickard, introduction to @@ -45,26 +45,26 @@ subroutine rhocoef(t, s, rhoref, alpha, beta) ! note: compression effects are not included implicit none - real(kind=kind_phys), intent(in) :: t, s, rhoref - real(kind=kind_phys), intent(out) :: alpha, beta + real(kind=kind_phys), intent(in) :: t, s, rhoref + real(kind=kind_phys), intent(out) :: alpha, beta real(kind=kind_phys) :: tc tc = t - t0k - alpha = & - 6.793952e-2 & - - 2.0 * 9.095290e-3 * tc + 3.0 * 1.001685e-4 * tc**2 & - - 4.0 * 1.120083e-6 * tc**3 + 5.0 * 6.536332e-9 * tc**4 & - - 4.0899e-3 * s & - + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & - + 4.0 * 5.3875e-9 * tc**3 * s & + alpha = & + 6.793952e-2 & + - 2.0 * 9.095290e-3 * tc + 3.0 * 1.001685e-4 * tc**2 & + - 4.0 * 1.120083e-6 * tc**3 + 5.0 * 6.536332e-9 * tc**4 & + - 4.0899e-3 * s & + + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & + + 4.0 * 5.3875e-9 * tc**3 * s & + 1.0227e-4 * s**1.5 - 2.0 * 1.6546e-6 * tc * s**1.5 ! note: rhoref - specify ! alpha = -alpha/rhoref - beta = & + beta = & 8.24493e-1 - 4.0899e-3 * tc & + 7.6438e-5 * tc**2 - 8.2467e-7 * tc**3 & + 5.3875e-9 * tc**4 - 1.5 * 5.72466e-3 * s**.5 & @@ -84,13 +84,13 @@ subroutine density(t, s, rho) real(kind=kind_phys), intent(in) :: t !unit, k real(kind=kind_phys), intent(in) :: s !unit, 1/1000 ! output - real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 + real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 ! local real(kind=kind_phys) :: tc - ! compute density using the international equation - ! of state of sea water 1980, (pond and pickard, - ! introduction to dynamical oceanography, pp310). + ! compute density using the international equation + ! of state of sea water 1980, (pond and pickard, + ! introduction to dynamical oceanography, pp310). ! compression effects are not included rho = 0.0 @@ -114,7 +114,7 @@ end subroutine density ! elemental subroutine sw_ps_9b(z,fxp) ! - ! fraction of the solar radiation absorbed by the ocean at the depth z + ! fraction of the solar radiation absorbed by the ocean at the depth z ! following paulson and simpson, 1981 ! ! input: @@ -146,7 +146,7 @@ end subroutine sw_ps_9b ! elemental subroutine sw_ps_9b_aw(z,aw) ! - ! d(fw)/d(z) for 9-band + ! d(fw)/d(z) for 9-band ! ! input: ! z: depth (m) @@ -297,8 +297,8 @@ end subroutine sw_fairall_simple_v1 elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z) ! ! solar radiation absorbed by the ocean at the depth z (zeng and beljaars, 2005, p.5) - ! - ! input: + ! + ! input: ! f_sol_0: solar radiation at the ocean surface (w/m^2) ! z: depth (m) ! @@ -324,7 +324,7 @@ elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z) ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) ! following soloviev, 1982 ! - ! input: + ! input: ! f_sol_0: solar radiation at the ocean surface (w/m^2) ! z: depth (m) ! @@ -353,8 +353,8 @@ elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) ! ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) ! following soloviev, 1982 - ! - ! input: + ! + ! input: ! f_sol_0: solar radiation at the ocean surface (w/m^2) ! z: depth (m) ! @@ -367,8 +367,8 @@ elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) ! if(z>0) then df_sol_z=f_sol_0*(1.0 & - -(0.28*0.014*(1.-exp(-z/0.014)) & - +0.27*0.357*(1.-exp(-z/0.357)) & + -(0.28*0.014*(1.-exp(-z/0.014)) & + +0.27*0.357*(1.-exp(-z/0.357)) & +.45*12.82*(1.-exp(-z/12.82)))/z & ) else @@ -440,7 +440,7 @@ function grv(lat) c3=0.0000001262 c4=0.0000000007 pi=3.141593 - + phi=lat*pi/180 x=sin(phi) grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) @@ -490,7 +490,7 @@ subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) ! jmnth - month ! jday - day ! jhr - hour -! jmn - minutes +! jmn - minutes ! output argument list: ! jd - julian day. ! fjd - fraction of the julian day. @@ -642,66 +642,56 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm ! Local variables integer :: i,j - real (kind=kind_phys), dimension(nx,ny) :: dtw,dtc - real (kind=kind_phys) :: dt_warm + real (kind=kind_phys) :: dt_warm, dtw, dtc, xzi + real (kind=kind_phys), parameter :: zero=0.0, half=0.5, one=1.0 -!$omp parallel do private(j,i) +!$omp parallel do private(j,i,dtw,dtc,xzi) do j = 1, ny do i= 1, nx -! -! initialize dtw & dtc as zeros -! - dtw(i,j) = 0.0 - dtc(i,j) = 0.0 -! if ( wet(i,j) .and. .not.icy(i,j) ) then + + dtm(i,j) = zero ! initialize dtm + if ( wet(i,j) ) then ! ! get the mean warming in the range of z=z1 to z=z2 ! - if ( xt(i,j) > 0.0 ) then - dt_warm = (xt(i,j)+xt(i,j))/xz(i,j) ! Tw(0) - if ( z1 < z2) then + dtw = zero + if ( xt(i,j) > zero ) then + xzi = one / xz(i,j) + dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0) + if (z1 < z2) then if ( z2 < xz(i,j) ) then - dtw(i,j) = dt_warm*(1.0-(z1+z2)/(xz(i,j)+xz(i,j))) - elseif ( z1 < xz(i,j) .and. z2 >= xz(i,j) ) then - dtw(i,j) = 0.5*(1.0-z1/xz(i,j))*dt_warm*(xz(i,j)-z1)/(z2-z1) + dtw = dt_warm * (one-half*(z1+z2)*xzi) + elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then + dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1) endif - elseif ( z1 == z2 ) then - if ( z1 < xz(i,j) ) then - dtw(i,j) = dt_warm*(1.0-z1/xz(i,j)) + elseif (z1 == z2 ) then + if (z1 < xz(i,j) ) then + dtw = dt_warm * (one-z1*xzi) endif endif endif ! ! get the mean cooling in the range of z=0 to z=zsea ! - if ( zc(i,j) > 0.0 ) then + dtc = zero + if ( zc(i,j) > zero ) then if ( z1 < z2) then if ( z2 < zc(i,j) ) then - dtc(i,j) = dt_cool(i,j)*(1.0-(z1+z2)/(zc(i,j)+zc(i,j))) + dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j))) elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then - dtc(i,j) = 0.5*(1.0-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) + dtc = half*(one-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) endif elseif ( z1 == z2 ) then if ( z1 < zc(i,j) ) then - dtc(i,j) = dt_cool(i,j)*(1.0-z1/zc(i,j)) + dtc = dt_cool(i,j) * (one-z1/zc(i,j)) endif endif endif - endif ! if ( wet(i,j) .and. .not.icy(i,j) ) then - enddo - enddo -! ! get the mean T departure from Tf in the range of z=z1 to z=z2 - -!$omp parallel do private(j,i) - do j = 1, ny - do i= 1, nx -! if ( wet(i,j) .and. .not.icy(i,j)) then - if ( wet(i,j) ) then - dtm(i,j) = dtw(i,j) - dtc(i,j) - endif + dtm(i,j) = dtw - dtc + endif ! if ( wet(i,j)) then enddo enddo From 8f6219475564319cd86e3b566b040c433358198a Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 26 May 2020 15:49:49 -0400 Subject: [PATCH 53/91] updating gitmodules --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 02895d59a..c563e5247 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,4 +9,4 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics - branch = SM_Apr282020 + branch = SM_May202020 From f79ebe2297d47f9223a14304048d1eb79568de08 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 27 May 2020 20:16:39 -0400 Subject: [PATCH 54/91] some fix related to ice in surface cycling in IPD --- ccpp/physics | 2 +- gfsphysics/physics/gcycle.F90 | 30 +++++++++--------- gfsphysics/physics/sfcsub.F | 57 ++++++++++++++++++++--------------- 3 files changed, 48 insertions(+), 41 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 760e9eabb..d810799b6 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 760e9eabb5610d3bd39465620553d2a7bd0f213e +Subproject commit d810799b637173f14360bad7727ef9f05a0351ba diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index 654c8ab93..f7dae4881 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -77,22 +77,22 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) len = 0 do jx = Model%jsc, (Model%jsc+Model%ny-1) - do ix = Model%isc, (Model%isc+Model%nx-1) - len = len + 1 - i_index(len) = ix - j_index(len) = jx - enddo + do ix = Model%isc, (Model%isc+Model%nx-1) + len = len + 1 + i_index(len) = ix + j_index(len) = jx + enddo enddo - sig1t = 0.0 + sig1t = 0.0_kind_phys npts = Model%nx*Model%ny ! len = 0 do nb = 1,nblks do ix = 1,size(Grid(nb)%xlat,1) len = len + 1 - RLA (len) = Grid(nb)%xlat (ix) * pifac - RLO (len) = Grid(nb)%xlon (ix) * pifac + RLA (len) = Grid(nb)%xlat (ix) * pifac + RLO (len) = Grid(nb)%xlon (ix) * pifac OROG (len) = Sfcprop(nb)%oro (ix) OROG_UF (len) = Sfcprop(nb)%oro_uf (ix) SLIFCS (len) = Sfcprop(nb)%slmsk (ix) @@ -135,18 +135,18 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) enddo - IF (SLIFCS(len) .LT. 0.1 .OR. SLIFCS(len) .GT. 1.5) THEN - SLMASK(len) = 0 + IF (SLIFCS(len) < 0.1_kind_phys .OR. SLIFCS(len) > 1.5_kind_phys) THEN + SLMASK(len) = 0.0_kind_phys ELSE - SLMASK(len) = 1 + SLMASK(len) = 1.0_kind_phys ENDIF - IF (SLIFCS(len) .EQ. 2) THEN - AISFCS(len) = 1. + IF (SLIFCS(len) > 1.99_kind_phys) THEN + AISFCS(len) = 1.0_kind_phys ELSE - AISFCS(len) = 0. + AISFCS(len) = 0.0_kind_phys ENDIF - if (Sfcprop(nb)%lakefrac(ix) > 0.0) then + if (Sfcprop(nb)%lakefrac(ix) > 0.0_kind_phys) then lake(len) = .true. else lake(len) = .false. diff --git a/gfsphysics/physics/sfcsub.F b/gfsphysics/physics/sfcsub.F index f3291e892..d3e94943b 100644 --- a/gfsphysics/physics/sfcsub.F +++ b/gfsphysics/physics/sfcsub.F @@ -2397,7 +2397,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do j = 1,lsoil do i = 1,len smcfcs(i,j) = smcanl(i,j) - if (slifcs(i) .gt. 0.0) then + if (slifcs(i) > 0.0_kind_io8) then stcfcs(i,j) = stcanl(i,j) else stcfcs(i,j) = tsffcs(i) @@ -2416,7 +2416,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & enddo !cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points -! crit=aislim +! crit = aislim do i=1,len sihfcs(i) = sihanl(i) sitfcs(i) = tsffcs(i) @@ -2425,38 +2425,46 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & else crit = min_seaice endif - if (slifcs(i) >= 2.) then + if (slifcs(i) >= 1.99_kind_io8) then if (sicfcs(i) > crit) then - tem1 = 1.0 / sicfcs(i) + tem1 = 1.0_kind_io8 / sicfcs(i) tsffcs(i) = (sicanl(i)*tsffcs(i) & + (sicfcs(i)-sicanl(i))*tgice) * tem1 sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 + sicfcs(i) = sicanl(i) else tsffcs(i) = tsfanl(i) ! tsffcs(i) = tgice - sihfcs(i) = sihnew +! sihfcs(i) = sihnew + sihfcs(i) = 0.0_kind_io8 + sicfcs(i) = 0.0_kind_io8 + slifcs(i) = 0.0_kind_io8 endif endif - sicfcs(i) = sicanl(i) - enddo - do i=1,len - if (slifcs(i) < 1.5) then - sihfcs(i) = 0. - sicfcs(i) = 0. - sitfcs(i) = tsffcs(i) - else - if (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif - if (sicfcs(i) < crit) then + if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then print *,'warning: check, slifcs and sicfcs', & & slifcs(i),sicfcs(i) - endif endif enddo +! do i=1,len +! if (slifcs(i) < 1.5_kind_io8) then +! sihfcs(i) = 0.0_kind_io8 +! sicfcs(i) = 0.0_kind_io8 +! sitfcs(i) = tsffcs(i) +! else +! if (lake(i)) then +! crit = min_lakeice +! else +! crit = min_seaice +! endif +! if (sicfcs(i) < crit) then +! print *,'warning: check, slifcs and sicfcs', & +! & slifcs(i),sicfcs(i) +! endif +! endif +! enddo + ! ! ensure the consistency between slc and smc ! @@ -7215,8 +7223,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & kpd7=-1 if (ialb == 1) then -!cbosu still need facsf and facwf. read them from the production -!cbosu file +!cbosu still need facsf and facwf. read them from the production file if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask &, alf,len,iret @@ -8023,8 +8030,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & return end subroutine clima subroutine fixrdc_tile(filename_raw, tile_num_ch, & - & i_index, j_index, kpds, & - & var, mon, npts, me) + & i_index, j_index, kpds, var, mon, npts, me) use netcdf use machine , only : kind_io8 implicit none @@ -8041,7 +8047,8 @@ subroutine fixrdc_tile(filename_raw, tile_num_ch, & integer :: nx, ny, num_times integer :: id_var real(kind=4), allocatable :: dummy(:,:,:) - ii=index(filename_raw,"tileX") + + ii = index(filename_raw,"tileX") do i = 1, len(filename) filename(i:i) = " " From 4ace2edbb0cc62d27f2dfaf907a344eab422ebcb Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 14 Jun 2020 23:54:01 +0000 Subject: [PATCH 55/91] some update to fv3_io and updte to ipd side of sfc_diff for when coupled to wave model --- ccpp/physics | 2 +- gfsphysics/physics/sfc_diff.f | 20 +++++++++---- io/FV3GFS_io.F90 | 54 ++++++++++++++++++++++++----------- 3 files changed, 53 insertions(+), 23 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index d810799b6..8b77f3694 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d810799b637173f14360bad7727ef9f05a0351ba +Subproject commit 8b77f369475e949bc1735c33e340a97d09f59c82 diff --git a/gfsphysics/physics/sfc_diff.f b/gfsphysics/physics/sfc_diff.f index 77bac2819..691483f94 100644 --- a/gfsphysics/physics/sfc_diff.f +++ b/gfsphysics/physics/sfc_diff.f @@ -264,18 +264,28 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) if (redrag) then z0rl(i,3) = 100.0d0 * max(min(z0, z0s_max), 1.0d-7) else - z0rl(i,3) = 100.0d0 * max(min(z0,0.1d0), 1.0d-7) + z0rl(i,3) = 100.0d0 * max(min(z0, 0.1d0), 1.0d-7) endif elseif (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m - z0rl(i,3) = 100.0d0 * z0 ! cm + call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m + z0rl(i,3) = 100.0d0 * z0 ! cm elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m - z0rl(i,3) = 100.0d0 * z0 ! cm + call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m + z0rl(i,3) = 100.0d0 * z0 ! cm else z0rl(i,3) = 1.0d-4 endif + + elseif (z0rl(i,3) <= 0.0d0) then + z0 = (charnock / grav) * ustar(i,3) * ustar(i,3) + + if (redrag) then + z0rl(i,3) = 100.0d0 * max(min(z0, z0s_max), 1.0d-7) + else + z0rl(i,3) = 100.0d0 * max(min(z0, 0.1d0), 1.0d-70) + endif + endif endif ! end of if(open ocean) diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 5b67a4497..9f67c9b4e 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -513,15 +513,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) real(kind=kind_phys), dimension(-2:4) :: dzsnso real(kind=kind_phys), dimension(4), save :: zsoil,dzs - data dzs /0.1_r8,0.3_r8,0.6_r8,1.0_r8/ + data dzs / 0.1_r8, 0.3_r8, 0.6_r8, 1.0_r8/ data zsoil /-0.1_r8,-0.4_r8,-1.0_r8,-2.0_r8/ - - if (Model%cplflx) then ! needs more variables - nvar_s2m = 34 - else - nvar_s2m = 32 - endif nvar_o2 = 19 nvar_s2o = 18 #ifdef CCPP @@ -605,6 +599,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Model%frac_grid = .false. !--- copy data into GFS containers + +!$omp parallel do default(shared) private(i, j, nb, ix) do nb = 1, Atm_block%nblks !--- 2D variables do ix = 1, Atm_block%blksz(nb) @@ -645,6 +641,12 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Model%frac_grid = .true. endif + if (Model%cplflx .or. Model%frac_grid) then ! needs more variables + nvar_s2m = 34 + else + nvar_s2m = 32 + endif + if (Model%me == Model%master ) write(0,*)' resetting Model%frac_grid=',Model%frac_grid !--- deallocate containers and free restart container @@ -671,8 +673,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp)) allocate(sfc_var3(nx,ny,Model%lsoil,nvar_s3)) #endif - sfc_var2 = -9999.0_r8 - sfc_var3 = -9999.0_r8 + sfc_var2 = -9999.0_r8 + sfc_var3 = -9999.0_r8 ! if (Model%lsm == Model%lsm_noahmp) then allocate(sfc_var3sn(nx,ny,-2:0,4:6)) @@ -906,6 +908,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) ! write(0,*)' sfc_var2=',sfc_var2(:,:,12) !--- place the data into the block GFS containers + +!$omp parallel do default(shared) private(i, j, nb, ix, lsoil) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) i = Atm_block%index(nb)%ii(ix) - isc + 1 @@ -945,7 +949,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%slope(ix) = sfc_var2(i,j,30) !--- slope Sfcprop(nb)%snoalb(ix) = sfc_var2(i,j,31) !--- snoalb Sfcprop(nb)%sncovr(ix) = sfc_var2(i,j,32) !--- sncovr - if(Model%cplflx) then + if(Model%cplflx .or. Model%frac_grid) then Sfcprop(nb)%tsfcl(ix) = sfc_var2(i,j,33) !--- sfcl (temp on land portion of a cell) Sfcprop(nb)%zorll(ix) = sfc_var2(i,j,34) !--- zorll (zorl on land portion of a cell) end if @@ -1151,11 +1155,16 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) ! in the FV3/non-CCPP physics when the CCPP-enabled executable is built. #endif !#ifndef CCPP + + i = Atm_block%index(1)%ii(1) - isc + 1 + j = Atm_block%index(1)%jj(1) - jsc + 1 + !--- if sncovr does not exist in the restart, need to create it - if (nint(sfc_var2(1,1,32)) == -9999) then + if (sfc_var2(i,j,32) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing sncovr') !--- compute sncovr from existing variables !--- code taken directly from read_fix.f +!$omp parallel do default(shared) private(nb, ix, vegtyp, rsnow) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) Sfcprop(nb)%sncovr(ix) = zero @@ -1173,9 +1182,11 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo endif - if(Model%cplflx .or. Model%frac_grid) then - if (nint(sfc_var2(1,1,33)) == -9999) then + if (Model%cplflx .or. Model%frac_grid) then + + if (sfc_var2(i,j,33) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tsfcl') +!$omp parallel do default(shared) private(nb, ix) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) !--- compute tsfcl from existing variables @@ -1183,8 +1194,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo endif - if (nint(sfc_var2(1,1,34)) == -9999) then + if (sfc_var2(i,j,34) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorll') +!$omp parallel do default(shared) private(nb, ix) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) !--- compute zorll from existing variables @@ -1196,19 +1208,21 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !#endif if(Model%frac_grid) then ! 3-way composite +!$omp parallel do default(shared) private(nb, ix, tem) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) Sfcprop(nb)%tsfco(ix) = max(con_tice, Sfcprop(nb)%tsfco(ix)) - tem = (1.-Sfcprop(nb)%landfrac(ix)) * Sfcprop(nb)%fice(ix) ! tem = ice fraction wrt whole cell + tem = (one-Sfcprop(nb)%landfrac(ix)) * Sfcprop(nb)%fice(ix) ! tem = ice fraction wrt whole cell Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) * Sfcprop(nb)%landfrac(ix) & - + Sfcprop(nb)%zorll(ix) * tem & !zorl ice = zorl land + + Sfcprop(nb)%zorll(ix) * tem & !zorl ice = zorl land + Sfcprop(nb)%zorlo(ix) * (one-Sfcprop(nb)%landfrac(ix)-tem) Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) * Sfcprop(nb)%landfrac(ix) & - + Sfcprop(nb)%tisfc(ix) * tem & + + Sfcprop(nb)%tisfc(ix) * tem & + Sfcprop(nb)%tsfco(ix) * (one-Sfcprop(nb)%landfrac(ix)-tem) enddo enddo else +!$omp parallel do default(shared) private(nb, ix, tem) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) !--- specify tsfcl/zorll from existing variable tsfco/zorlo @@ -1806,6 +1820,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta endif +!$omp parallel do default(shared) private(i, j, nb, ix, lsoil) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) !--- 2D variables @@ -2062,6 +2077,7 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) !--- place the data into the block GFS containers !--- phy_var* variables +!$omp parallel do default(shared) private(i, j, nb, ix) do num = 1,nvar2d do nb = 1,Atm_block%nblks do ix = 1, Atm_block%blksz(nb) @@ -2074,6 +2090,7 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) !-- if restart from init time, reset accumulated diag fields if( Model%phour < 1.e-7) then do num = fdiag,ldiag +!$omp parallel do default(shared) private(i, j, nb, ix) do nb = 1,Atm_block%nblks do ix = 1, Atm_block%blksz(nb) i = Atm_block%index(nb)%ii(ix) - isc + 1 @@ -2084,6 +2101,7 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) enddo endif do num = 1,nvar3d +!$omp parallel do default(shared) private(i, j, k, nb, ix) do nb = 1,Atm_block%nblks do k=1,npz do ix = 1, Atm_block%blksz(nb) @@ -2156,6 +2174,7 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta endif !--- 2D variables +!$omp parallel do default(shared) private(i, j, num, nb, ix) do num = 1,nvar2d do nb = 1,Atm_block%nblks do ix = 1, Atm_block%blksz(nb) @@ -2166,6 +2185,7 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta enddo enddo !--- 3D variables +!$omp parallel do default(shared) private(i, j, k, num, nb, ix) do num = 1,nvar3d do nb = 1,Atm_block%nblks do k=1,npz From 8e977b4b0793a0ff44af39fd047bfc71d6d64be6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 17 Jun 2020 23:22:59 +0000 Subject: [PATCH 56/91] reverting in atmos_model.F90 mytile instead of mygrid to use with older FMS and dycore --- atmos_cubed_sphere | 2 +- atmos_model.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 3ff1ed2ad..15c615f80 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 3ff1ed2adb10bbe892c9d9d010bb5b11c66ce425 +Subproject commit 15c615f80e745848d0af50a47174e7c6dc851236 diff --git a/atmos_model.F90 b/atmos_model.F90 index 9eda63545..ef62c3c5b 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -78,7 +78,7 @@ module atmos_model_mod use atmosphere_mod, only: atmosphere_scalar_field_halo use atmosphere_mod, only: atmosphere_get_bottom_layer use atmosphere_mod, only: set_atmosphere_pelist -use atmosphere_mod, only: Atm, mygrid +use atmosphere_mod, only: Atm, mytile use block_control_mod, only: block_control_type, define_blocks_packed use DYCORE_typedefs, only: DYCORE_data_type, DYCORE_diag_type #ifdef CCPP @@ -610,8 +610,8 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) Init_parm%area => Atmos%area Init_parm%tracer_names => tracer_names #ifdef CCPP - Init_parm%restart = Atm(mygrid)%flagstruct%warm_start - Init_parm%hydrostatic = Atm(mygrid)%flagstruct%hydrostatic + Init_parm%restart = Atm(mytile)%flagstruct%warm_start + Init_parm%hydrostatic = Atm(mytile)%flagstruct%hydrostatic #endif #ifdef INTERNAL_FILE_NML @@ -683,7 +683,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) endif endif - Atm(mygrid)%flagstruct%do_skeb = IPD_Control%do_skeb + Atm(mytile)%flagstruct%do_skeb = IPD_Control%do_skeb ! initialize the IAU module call iau_initialize (IPD_Control,IAU_data,Init_parm) @@ -704,7 +704,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) call FV3GFS_diag_register (IPD_Diag, Time, Atm_block, IPD_Control, Atmos%lon, Atmos%lat, Atmos%axes) call IPD_initialize_rst (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) #ifdef CCPP - call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain, Atm(mygrid)%flagstruct%warm_start) + call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain, Atm(mytile)%flagstruct%warm_start) #else call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain) #endif From 2d2deae71b14696a98002b77e5774a7934b1c2dc Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 29 Jun 2020 23:39:41 +0000 Subject: [PATCH 57/91] updating sfc_diff.f to recompute z0 over ocean when coupled to ww3 and value is below 1.0e-7 --- ccpp/physics | 2 +- gfsphysics/physics/sfc_diff.f | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index e450d811b..37444dc7d 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit e450d811b464308e38838e317ee2a912b6490c9e +Subproject commit 37444dc7da2af9399c17c1c9bd63b100ea0fd81c diff --git a/gfsphysics/physics/sfc_diff.f b/gfsphysics/physics/sfc_diff.f index 77096794a..f150cdfc4 100644 --- a/gfsphysics/physics/sfc_diff.f +++ b/gfsphysics/physics/sfc_diff.f @@ -269,13 +269,13 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) z0rl(i,3) = 1.0d-4 endif - elseif (z0rl(i,3) <= 0.0d0) then + elseif (z0rl(i,3) < 1.0d-7) then z0 = (charnock / grav) * ustar(i,3) * ustar(i,3) if (redrag) then z0rl(i,3) = 100.0d0 * max(min(z0, z0s_max), 1.0d-7) else - z0rl(i,3) = 100.0d0 * max(min(z0, 0.1d0), 1.0d-70) + z0rl(i,3) = 100.0d0 * max(min(z0, 0.1d0), 1.0d-7) endif endif From b37e5f1f64c5f837b3c7759705775c602a45d95d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 30 Jun 2020 13:31:04 +0000 Subject: [PATCH 58/91] minor change in physics driver to turn on huge --- atmos_model.F90 | 3 --- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 14 ++++---------- 2 files changed, 4 insertions(+), 13 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index ef62c3c5b..90c10a6be 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -339,7 +339,6 @@ subroutine update_atmos_radiation_physics (Atmos) call assign_importdata(rc) -! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in atmos_model, after assign_importdata, rc=',rc endif call mpp_clock_end(setupClock) @@ -1659,8 +1658,6 @@ subroutine assign_importdata(rc) name=impfield_name, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return -! if (mpp_pe() == mpp_root_pe() .and. debug) print *,'in cplIMP,atmos gets ',' n=',n,trim(impfield_name) - if ( dimCount == 2) then if ( datatype == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(importFields(n),farrayPtr=datar82d,localDE=0, rc=rc) diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index e0a7461a6..fa7c7c82f 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -17,8 +17,7 @@ module module_physics_driver GFS_sfcprop_type, GFS_coupling_type, & GFS_control_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & - GFS_radtend_type, GFS_diag_type -! GFS_radtend_type, GFS_diag_type, huge + GFS_radtend_type, GFS_diag_type, huge use gfdl_cloud_microphys_mod, only: gfdl_cloud_microphys_driver, & cloud_diagnosis use module_mp_thompson, only: mp_gt_driver @@ -60,7 +59,6 @@ module module_physics_driver real(kind=kind_phys), parameter :: con_day = 86400.0_kind_phys real(kind=kind_phys), parameter :: rad2dg = 180.0_kind_phys/con_pi real(kind=kind_phys), parameter :: omz1 = 2.0_kind_phys - real(kind=kind_phys), parameter :: huge = zero !> GFS Physics Implementation Layer !> @brief Layer that invokes individual GFS physics routines @@ -515,7 +513,6 @@ subroutine GFS_physics_driver & stress, t850, ep1d, gamt, gamq, sigmaf, & wind, work1, work2, work3, work4, runof, xmu, fm10, fh2, & tx1, tx2, tx3, tx4, ctei_r, evbs, evcw, trans, sbsno,& -! dnsst, tx1, tx2, tx3, tx4, ctei_r, evbs, evcw, trans, sbsno,& snowc, frland, adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, & adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, adjnirbmd, & adjnirdfd, adjvisbmd, adjvisdfd, xcosz, tseal, & @@ -811,8 +808,8 @@ subroutine GFS_physics_driver & ! lprnt = .false. ! do i=1,im -! lprnt = kdt >= 24 .and. abs(grid%xlon(i)*rad2dg-239.50) < 0.151 & -! .and. abs(grid%xlat(i)*rad2dg-75.05) < 0.201 +! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-97.50) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-24.48) < 0.101 ! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-293.91) < 0.101 & ! .and. abs(grid%xlat(i)*rad2dg+72.02) < 0.101 ! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-113.48) < 0.101 & @@ -829,7 +826,7 @@ subroutine GFS_physics_driver & ! endif ! enddo ! if (lprnt) then -! if (MOdel%cplflx) then +! if (Model%cplflx) then ! write(0,*)' sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt, & ! ' fice=',Sfcprop%fice(ipr),' ulw=',Coupling%ulwsfcin_cpl(ipr), & ! ' tsfc=',Sfcprop%tsfc(ipr) @@ -1711,10 +1708,7 @@ subroutine GFS_physics_driver & Sfcprop%z_c, wet, zero, omz1, im, 1, dtzm) do i=1,im if (wet(i) .and. Sfcprop%oceanfrac(i) > zero) then -! dnsst = tsfc3(i,3) - Sfcprop%tref(i) ! retrive/get difference of Ts and Tf Sfcprop%tref(i) = Sfcprop%tsfco(i) - dtzm(i) ! update Tf with T1 and NSST T-Profile -! tsfc3(i,3) = max(271.2,Sfcprop%tref(i) + dnsst ! get Ts updated due to Tf update -! tseal(i) = tsfc3(i,3) if (abs(Sfcprop%xz(i)) > zero) then tem2 = one / Sfcprop%xz(i) else From 20fbd4086ab6144eff1480f60430c180eb72862b Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 8 Jul 2020 00:48:42 +0000 Subject: [PATCH 59/91] fixing errors/logic with fractional grid option to reproduce a continuous run from a restart run, both with IPD and CCPP physics --- atmos_model.F90 | 4 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 179 +++++++++++++++--- gfsphysics/GFS_layer/GFS_radiation_driver.F90 | 26 ++- gfsphysics/GFS_layer/GFS_typedefs.F90 | 3 + gfsphysics/GFS_layer/GFS_typedefs.meta | 11 +- gfsphysics/physics/dcyc2.f | 2 + gfsphysics/physics/gcycle.F90 | 10 +- gfsphysics/physics/radiation_surface.f | 4 +- gfsphysics/physics/sfc_diff.f | 2 - io/FV3GFS_io.F90 | 84 +++++--- 10 files changed, 261 insertions(+), 64 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 90c10a6be..c371460fc 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1776,8 +1776,8 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Sfcprop%fice(ix) = max(zero, min(one, datar8(i,j)/ofrac)) !LHS: ice frac wrt water area if (IPD_Data(nb)%Sfcprop%fice(ix) >= IPD_control%min_seaice) then if (IPD_Data(nb)%Sfcprop%fice(ix) > one-epsln) IPD_Data(nb)%Sfcprop%fice(ix) = one -! if (abs(one-ofrac) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points - IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys + if (abs(one-ofrac) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys !slmsk=2 crashes in gcycle on partial land points +! IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4.0_IPD_kind_phys else IPD_Data(nb)%Sfcprop%fice(ix) = zero diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index fa7c7c82f..7e2114c75 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -17,6 +17,7 @@ module module_physics_driver GFS_sfcprop_type, GFS_coupling_type, & GFS_control_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & +! GFS_radtend_type, GFS_diag_type GFS_radtend_type, GFS_diag_type, huge use gfdl_cloud_microphys_mod, only: gfdl_cloud_microphys_driver, & cloud_diagnosis @@ -59,6 +60,7 @@ module module_physics_driver real(kind=kind_phys), parameter :: con_day = 86400.0_kind_phys real(kind=kind_phys), parameter :: rad2dg = 180.0_kind_phys/con_pi real(kind=kind_phys), parameter :: omz1 = 2.0_kind_phys +! real(kind=kind_phys), parameter :: huge = 0.0_kind_phys !> GFS Physics Implementation Layer !> @brief Layer that invokes individual GFS physics routines @@ -808,8 +810,16 @@ subroutine GFS_physics_driver & ! lprnt = .false. ! do i=1,im -! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-97.50) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg-24.48) < 0.101 +! lprnt = Model%me == 23 .and. i == 25 +! lprnt = Model%me == 127 .and. i == 11 +! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-102.65) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-0.12) < 0.201 +! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-184.00) < 0.301 & +! .and. abs(grid%xlat(i)*rad2dg-83.23) < 0.301 +! lprnt = kdt >= 7 .and. abs(grid%xlon(i)*rad2dg-216.20) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-81.23) < 0.101 +! lprnt = kdt >= 7 .and. abs(grid%xlon(i)*rad2dg-28.800) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg+2.45) < 0.101 ! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-293.91) < 0.101 & ! .and. abs(grid%xlat(i)*rad2dg+72.02) < 0.101 ! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-113.48) < 0.101 & @@ -832,8 +842,13 @@ subroutine GFS_physics_driver & ! ' tsfc=',Sfcprop%tsfc(ipr) ! else ! write(0,*)' sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt, & -! ' fice=',Sfcprop%fice(ipr), ' tsfc=',Sfcprop%tsfc(ipr) +! ' fice=',Sfcprop%fice(ipr), ' tsfc=',Sfcprop%tsfc(ipr), & +! 'tsfcl=',Sfcprop%tsfcl(ipr),' tsfco=',Sfcprop%tsfco(ipr) ! endif +! if (Model%nstf_name(1) > 0) then +! write(0,*)' begin sfcprop%tref=',Sfcprop%tref(ipr),' kdt=',kdt, & +! ' landfrac=',Sfcprop%landfrac(ipr) +! endif ! endif !------------------------------------------------------------------------------------------- ! @@ -841,8 +856,9 @@ subroutine GFS_physics_driver & ! write(0,*)' in phydrv tgrs=',Statein%tgrs(ipr,:) ! write(0,*)' in phydrv ugrs=',Statein%ugrs(ipr,:) ! write(0,*)' in phydrv vgrs=',Statein%vgrs(ipr,:) -! write(0,*)' in phydrv qgrs=',Statein%qgrs(ipr,:,1) +! write(0,*)' in phydrv qgrs=',Statein%qgrs(ipr,:,1)*1000.0 ! write(0,*)' in phydrv tke=',Statein%qgrs(ipr,:,ntke) +! write(0,*)' in phydrv phii=',Statein%phii(ipr,:) ! endif ! ! --- ... frain=factor for centered difference scheme correction of rain amount. @@ -1016,15 +1032,20 @@ subroutine GFS_physics_driver & Statein%prsl, Statein%prslk, Statein%phii, Statein%phil, del) #else !GFDL Adjust the geopotential height hydrostatically in a way consistent with FV3 discretization +! if (lprnt) write(0,*)'bef get_prs_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt + call get_prs_fv3 (ix, levs, ntrac, Statein%phii, Statein%prsi, & Statein%tgrs, Statein%qgrs, del, del_gz) #endif +! if (lprnt) write(0,*)'aft get_prs_fv3 phii=',Statein%phii(ipr,:) +! if (lprnt) write(0,*)'aft get_prs_fv3 del_gz=',del_gz(ipr,:) !*## CCPP ## !## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run do i = 1, IM sigmaf(i) = max( Sfcprop%vfrac(i),0.01_kind_phys ) islmsk(i) = nint(Sfcprop%slmsk(i)) + islmsk_cice(i) = islmsk(i) if (islmsk(i) == 2) then if (Model%isot == 1) then @@ -1107,24 +1128,31 @@ subroutine GFS_physics_driver & if (flag_cice(i)) then if (fice(i) >= Model%min_seaice) then icy(i) = .true. + if (fice(i) < one) wet(i) = .true. ! some open ocean/lake water exists else fice(i) = zero flag_cice(i) = .false. islmsk_cice(i) = 0 - islmsk(i) = 0 +! islmsk(i) = 0 + wet(i) = .true. ! some open ocean/lake water exists endif else if (fice(i) >= Model%min_lakeice) then icy(i) = .true. + if (fice(i) < one) wet(i) = .true. ! some open ocean/lake water exists + islmsk(i) = 2 else fice(i) = zero - islmsk(i) = 0 +! islmsk(i) = 0 + wet(i) = .true. ! some open ocean/lake water exists endif endif - if (fice(i) < one) then - wet(i) = .true. ! some open ocean/lake water exists - if ((.not. Model%cplflx .or. Sfcprop%oceanfrac(i) == zero) .and. icy(i)) & + if (wet(i) .and. .not. Model%cplflx) then + if (Sfcprop%oceanfrac(i) > zero) then + Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) + elseif (icy(i)) then Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) + endif endif else fice(i) = zero @@ -1209,6 +1237,8 @@ subroutine GFS_physics_driver & enddo endif endif +! if (lprnt) write(0,*)' dry=',dry(ipr),' wet=',wet(ipr),' icy=',icy(ipr) ,& +! ' tsfco=',Sfcprop%tsfco(ipr) do i=1,im if(wet(i)) then ! Water zorl3(i,3) = Sfcprop%zorlo(i) @@ -1234,7 +1264,7 @@ subroutine GFS_physics_driver & if (icy(i)) then ! Ice uustar3(i,2) = Sfcprop%uustar(i) weasd3(i,2) = Sfcprop%weasd(i) - zorl3(i,2) = Sfcprop%zorll(i) + zorl3(i,2) = Sfcprop%zorli(i) tsfc3(i,2) = Sfcprop%tisfc(i) tsurf3(i,2) = Sfcprop%tisfc(i) snowd3(i,2) = Sfcprop%snowd(i) @@ -1542,7 +1572,7 @@ subroutine GFS_physics_driver & enddo endif ! if (lprnt) write(0,*)' kdt=',kdt,' tsfc=',Sfcprop%tsfc(ipr),' adjsfculw=',adjsfculw(ipr),& -! ' adjsfculw3=',adjsfculw3(ipr,:),' icefr=',Sfcprop%fice(ipr),' tsfc3=',tsfc3(ipr,:) +! ' adjsfculw3=',adjsfculw3(ipr,:),' icefr=',fice(ipr),' tsfc3=',tsfc3(ipr,:) ! do i=1,im Diag%dlwsfc(i) = Diag%dlwsfc(i) + adjsfcdlw(i)*dtf @@ -1663,8 +1693,9 @@ subroutine GFS_physics_driver & ! --- ... surface exchange coefficients ! -! if (lprnt) write(0,*)' tsfc=',Sfcprop%tsfc(ipr),' tsurf=',tsurf(ipr),'iter=', & -! iter ,'wet=',wet(ipr),'dry=',dry(ipr),' icy=',icy(ipr) +! if (lprnt) write(0,*)' tsfc=',Sfcprop%tsfc(ipr),'iter=', & +! iter ,'wet=',wet(ipr),'dry=',dry(ipr),' icy=',icy(ipr),& +! ' zorl3=',zorl3(ipr,:),' uustar3=',uustar3(ipr,:) !## CCPP ##* sfc_diff.f/sfc_diff_run call sfc_diff & @@ -1683,6 +1714,8 @@ subroutine GFS_physics_driver & cd3, cdq3, rb3, stress3, ffmm3, ffhh3, fm103, fh23) ! cd3, cdq3, rb3, stress3, ffmm3, ffhh3, fm103, fh23, wind, lprnt, ipr) ! +! if (lprnt) write(0,*)' aft sfc_diff cd3=',cd3(ipr,:),' cdq3=',cdq3(ipr,:),'iter=', iter, & +! ' zorl3=',zorl3(ipr,:),' uustar3=',uustar3(ipr,:) ! --- ... lu: update flag_guess !*## CCPP ## !## CCPP ##* GFS_surface_loop_control/GFS_surface_loop_control_part1_run @@ -1722,7 +1755,12 @@ subroutine GFS_physics_driver & endif ! if (lprnt) write(0,*)' bef nst tseal=',tseal(ipr) & -! ,' tsfc3=',tsfc3(ipr,3),' tsurf3=',tsurf3(ipr,3),' tem=',tem +! ,' tsfc3=',tsfc3(ipr,3),' tsurf3=',tsurf3(ipr,3), & +! iter ,'wet=',wet(ipr),'dry=',dry(ipr),' icy=',icy(ipr),& +! ' tref=',Sfcprop%tref(ipr),' tgrs=',Statein%tgrs(ipr,1),' qgrs=',Statein%qgrs(ipr,1,1), & +! ' prsl=',Statein%prsl(ipr,1),' cd3=',cd3(ipr,3),' cdq3=',cdq3(ipr,3),' work3=', & +! work3(ipr),' semis3=',semis3(ipr,3),' gabsbdlw3=',gabsbdlw3(ipr,3),' adjsfcnsw=', & +! adjsfcnsw(ipr),' wind=',wind(ipr),' tseal=',tseal(ipr),' xcosz=',xcosz(ipr) !*## CCPP ## !## CCPP ##* sfc_nst.f/sfc_nst_run call sfc_nst & @@ -1774,6 +1812,9 @@ subroutine GFS_physics_driver & endif enddo endif + +! if (lprnt) write(0,*)' aft nst tref=',Sfcprop%tref(ipr) & +! ,' tsfc3=',tsfc3(ipr,3),' dtzm=',dtzm(ipr),' hflx33=',hflx3(ipr,3) !*## CCPP ## ! if (lprnt) print *,' tseaz2=',Sfcprop%tsfc(ipr),' tref=',tref(ipr), & ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt @@ -1836,10 +1877,10 @@ subroutine GFS_physics_driver & snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) !*## CCPP ## -! if (lprnt) write(0,*)' tseae=',tseal(ipr),' tsurf=',tsurf(ipr),iter& +! if (lprnt) write(0,*)' tseae=',tseal(ipr),' tsurf=',tsurf(ipr),iter ! ,' phy_f2d=',phy_f2d(ipr,num_p2d) -! if (lprnt) write(0,*)' hflx3=',hflx3(ipr,:),' evap3=',evap3(i,:) +! if (lprnt) write(0,*)' hflx3=',hflx3(ipr,:),' evap3=',evap3(ipr,:) !## CCPP ##* sfc_noahmp_drv.f/noahmpdrv_run ! Noah MP call @@ -1920,14 +1961,14 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)' tseabeficemodel =',Sfcprop%tsfc(ipr),' me=',me & ! &, ' kdt=',kdt,' tsfc32=',tsfc3(ipr,2),' fice=',fice(ipr) & -! &,' stsoil=',stsoil(ipr,:) +! &,' stsoil=',stsoil(ipr,:),' tsfc33=',tsfc3(ipr,3),' islmsk=',islmsk(ipr) ! --- ... surface energy balance over seaice !## CCPP ##* sfc_sice.f/sfc_sice_run (local adjustment to avoid resetting islmsk after call to sfc_sice_run) if (Model%cplflx) then do i=1,im if (flag_cice(i)) then - islmsk (i) = islmsk_cice(i) + islmsk(i) = islmsk_cice(i) endif enddo !*## CCPP ## @@ -1953,15 +1994,30 @@ subroutine GFS_physics_driver & ! ! call sfc_sice for lake ice and for the uncoupled case, sea ice (i.e. islmsk=2) ! + if (Model%frac_grid) then + do i=1,im + if (icy(i) .and. islmsk(i) < 2) then + if (Sfcprop%oceanfrac(i) > zero) then + tem = Model%min_seaice + else + tem = Model%min_lakeice + endif + if (fice(i) > tem) then + islmsk(i) = 2 + tsfc3(i,2) = Sfcprop%tisfc(i) + endif + endif + enddo + endif !## CCPP ##* sfc_sice.f/sfc_sice_run call sfc_sice & ! --- inputs: - (im, lsoil, Statein%pgr, & + (im, lsoil, Statein%pgr, & Statein%tgrs(:,1), Statein%qgrs(:,1,1), dtf, semis3(:,2), & ! Statein%tgrs(:,1), Statein%qgrs(:,1,1), dtf, Radtend%semis, & gabsbdlw3(:,2), adjsfcnsw, adjsfcdsw, Sfcprop%srflag, & cd3(:,2), cdq3(:,2), & - Statein%prsl(:,1), work3, islmsk, wind, & + Statein%prsl(:,1), work3, islmsk, wind, & flag_iter, lprnt, ipr, Model%min_lakeice, & ! --- input/output: zice, fice, tice, weasd3(:,2), tsfc3(:,2), tprcp3(:,2), & @@ -1971,6 +2027,14 @@ subroutine GFS_physics_driver & evap3(:,2), hflx3(:,2)) !*## CCPP ## !## CCPP ##* This section is not needed for CCPP. + if (Model%frac_grid) then + do i = 1, im + if (islmsk(i) == 2 .and. fice(i) < one) then + wet(i) = .true. + tsfc3(i,3) = max(Sfcprop%tisfc(i), tgice) + endif + enddo + endif if (Model%cplflx) then do i = 1, im if (flag_cice(i)) then @@ -1980,8 +2044,9 @@ subroutine GFS_physics_driver & endif !*## CCPP ## -! if (lprnt) write(0,*)' tseaafticemodel =',tsfc3(ipr,2),' me=',me & -! &, ' kdt=',kdt,' iter=',iter,' fice=',fice(ipr) +! if (lprnt) write(0,*)' tseaafticemodel =',tsfc3(ipr,:),' me=',me & +! &, ' kdt=',kdt,' iter=',iter,' fice=',fice(ipr),' wet=',wet(ipr),' icy=',icy(ipr)& +! &,' dry=',dry(ipr) ! --- ... lu: update flag_iter and flag_guess !## CCPP ##* GFS_surface_loop_control.F90/GFS_surface_loop_control_part_2 @@ -2012,6 +2077,11 @@ subroutine GFS_physics_driver & txl = frland(i) txi = fice(i)*(one - frland(i)) ! txi = ice fraction wrt whole cell txo = max(zero, one - txl - txi) + +! if (i == ipr .and. lprnt) write(0,*)' txl=',txl,' fice=',fice(i),' txi=',txi,& +! ' txo=',txo,' dry=',dry(i),' wet=',wet(i),' icy=',icy(i),' oceanfrac=',& +! Sfcprop%oceanfrac(i),' frland=',frland(i) + Sfcprop%zorl(i) = txl*zorl3(i,1) + txi*zorl3(i,2) + txo*zorl3(i,3) cd(i) = txl*cd3(i,1) + txi*cd3(i,2) + txo*cd3(i,3) cdq(i) = txl*cdq3(i,1) + txi*cdq3(i,2) + txo*cdq3(i,3) @@ -2049,14 +2119,41 @@ subroutine GFS_physics_driver & Sfcprop%tsfc(i) = txl*tsfc3(i,1) + txi*tice(i) + txo*tsfc3(i,3) ! Sfcprop%tsfc(i) = txl*tsfc3(i,1) + txi*tsfc3(i,2) + txo*tsfc3(i,3) +! if (i == ipr .and. lprnt) then +! write(0,*)' tsfc=',Sfcprop%tsfc(i),' txl=',txl,' txi=',txi,' txo=',txo, & +! ' tsfc3=',tsfc3(i,:),' evap3=',evap3(i,:),' evap=',evap(i),' tice=',tice(i),& +! 'Sfcprop%zorl=',Sfcprop%zorl(ipr) +! endif + ! Diag%cmm(i) = txl*cmm3(i,1) + txi*cmm3(i,2) + txo*cmm3(i,3) ! Diag%chh(i) = txl*chh3(i,1) + txi*chh3(i,2) + txo*chh3(i,3) Sfcprop%zorll(i) = zorl3(i,1) + Sfcprop%zorli(i) = zorl3(i,2) Sfcprop%zorlo(i) = zorl3(i,3) - if (dry(i)) Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land - if (wet(i)) Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake or ocean when uncoupled + if (dry(i)) then + Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land + elseif (wet(i)) then + Sfcprop%tsfcl(i) = tsfc3(i,3) ! over land + else + Sfcprop%tsfcl(i) = tice(i) ! over land + endif + if (wet(i)) then + Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake or ocean when uncoupled + elseif (icy(i)) then + Sfcprop%tsfco(i) = tice(i) ! over lake or ocean when uncoupled + else + Sfcprop%tsfco(i) = tsfc3(i,1) ! over lake or ocean when uncoupled + endif + if (icy(i)) then + Sfcprop%tisfc(i) = tice(i) ! over lake or ocean when uncoupled +! if (Sfcprop%zorll(i) > 1000.0) Sfcprop%zorll(i) = zorl3(i,2) + elseif (wet(i)) then + Sfcprop%tisfc(i) = tsfc3(i,3) ! over lake or ocean when uncoupled + else + Sfcprop%tisfc(i) = tsfc3(i,1) ! over lake or ocean when uncoupled + endif ! for coupled model ocean will replace this ! if (icy(i)) Sfcprop%tisfc(i) = tsfc3(i,2) ! over ice when uncoupled ! if (icy(i)) Sfcprop%tisfc(i) = tice(i) ! over ice when uncoupled @@ -2067,7 +2164,8 @@ subroutine GFS_physics_driver & ! endif if (.not. flag_cice(i)) then - if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array +! if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array + if (icy(i)) then ! return updated lake ice thickness & concentration to global array Sfcprop%hice(i) = zice(i) Sfcprop%fice(i) = fice(i) Sfcprop%tisfc(i) = tice(i) @@ -2080,6 +2178,10 @@ subroutine GFS_physics_driver & enddo else do i=1,im + if (flag_cice(i) .and. wet(i) .and. fice(i) < Model%min_seaice) then + islmsk(i) = 0 + fice(i) = zero + endif if (islmsk(i) == 1) then k = 1 Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land @@ -2121,6 +2223,7 @@ subroutine GFS_physics_driver & Sfcprop%tsfc(i) = tsfc3(i,k) Sfcprop%zorll(i) = zorl3(i,1) + Sfcprop%zorli(i) = zorl3(i,2) Sfcprop%zorlo(i) = zorl3(i,3) if (flag_cice(i)) then @@ -2150,6 +2253,9 @@ subroutine GFS_physics_driver & else Sfcprop%tsfco(i) =Sfcprop%tsfc(i) endif + do k=1,Model%kice ! store tiice in stc to reduce output in the nonfrac grid case + Sfcprop%stc(i,k) = Sfcprop%tiice(i,k) + enddo enddo endif ! if (Model%frac_grid) !*## CCPP ## @@ -2355,6 +2461,7 @@ subroutine GFS_physics_driver & ! enddo ! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat +! if (lprnt) write(0,*)'befmonshoc phii=',Statein%phii(ipr,:) ! if (lprnt) write(0,*)'befmonshoc=',Statein%tgrs(ipr,:) ! if (lprnt) write(0,*)'befmonshocdtdt=',dtdt(ipr,1:10) ! if (lprnt) write(0,*)'befmonshoctkh=',Tbd%phy_f3d(ipr,1:10,ntot3d-1) @@ -2387,8 +2494,9 @@ subroutine GFS_physics_driver & Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, Model%xkzminv, & lprnt, ipr, me) ! if (lprnt) then +! write(0,*)' aftpbl phii=',Statein%phii(ipr,:) ! write(0,*)' aftpbl dtdt=',dtdt(ipr,:) -! write(0,*)' aftpbl dqdtv=',dqdt(ipr,:,1) +! write(0,*)' aftpbl dqdtv=',dqdt(ipr,:,1) ! write(0,*)'aftmonshoc=',Statein%tgrs(ipr,:) ! write(0,*)'aftmonshocq=',Statein%qgrs(ipr,:,1) ! write(0,*)'aftmonshoctke=',Statein%qgrs(ipr,:,ntke) @@ -2396,6 +2504,7 @@ subroutine GFS_physics_driver & ! write(0,*)'aftmonwat=',Statein%qgrs(ipr,:,ntcw) ! write(0,*)'aftmonshocdtdt=',dtdt(ipr,1:10) ! endif + else if (Model%satmedmf) then if (Model%isatmedmf == 0) then ! initial version of satmedmfvdif (Nov 2018) @@ -3376,9 +3485,15 @@ subroutine GFS_physics_driver & Model%gen_coord_hybrid Statein%prsi, Statein%prsik, & Statein%prsl, Statein%prslk, Statein%phii, Statein%phil) #else +! if (lprnt) write(0,*)'bef get_phi_fv3 gt0=',Stateout%gt0(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)'bef get_phi_fv3 gq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)'bef get_phi_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt + !GFDL Adjust the height hydrostatically in a way consistent with FV3 discretization call get_phi_fv3 (ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & del_gz, Statein%phii, Statein%phil) + +! if (lprnt) write(0,*)'aft get_phi_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt #endif !*## CCPP ## @@ -3621,6 +3736,7 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)'gt01=',Stateout%gt0(ipr,:) ! if (lprnt) write(0,*)'gq01=',Stateout%gq0(ipr,:,1) +! if (lprnt) write(0,*)'phii=',Statein%phii(ipr,:),' kdt=',kdt ! if (lprnt) write(0,*)'clwi=',clw(ipr,:,1) ! if (lprnt) write(0,*)'clwl=',clw(ipr,:,2) ! if (lprnt) write(0,*)'befncpi=',ncpi(ipr,:) @@ -5578,6 +5694,7 @@ subroutine GFS_physics_driver & ! write(0,*) ' endgt0=',Stateout%gt0(ipr,:),' kdt=',kdt ! write(0,*) ' endgq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt ! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat +! write(0,*) ' endzorl=',Sfcprop%zorl(ipr),' kdt=',kdt ! endif if (Model%do_sppt .or. Model%ca_global)then @@ -5678,6 +5795,16 @@ subroutine GFS_physics_driver & enddo !*## CCPP ## ! if (kdt > 2 ) stop + +! if (Model%nstf_name(1) > 0) then +! if (lprnt) write(0,*)' end driver sfcprop%tref=',Sfcprop%tref(ipr),' kdt=',kdt +! endif +! if (Model%frac_grid) then +! if (lprnt) write(0,*)' end driver sfcprop%tsfcl=',Sfcprop%tsfcl(ipr),' kdt=',kdt +! if (lprnt) write(0,*)' end driver sfcprop%tsfco=',Sfcprop%tsfco(ipr),' kdt=',kdt +! if (lprnt) write(0,*)' end driver sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt +! endif + return !................................... end subroutine GFS_physics_driver diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 index a029063ff..0a551ef19 100644 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 @@ -319,7 +319,7 @@ module module_radiation_driver ! & epsm1 => con_epsm1, & & fvirt => con_fvirt & &, rog => con_rog & - &, rocp => con_rocp + &, rocp => con_rocp, pi => con_pi use funcphys, only: fpvs use module_radiation_astronomy,only: sol_init, sol_update, coszmn @@ -1230,6 +1230,9 @@ subroutine GFS_radiation_driver & !--- TYPED VARIABLES type (cmpfsw_type), dimension(size(Grid%xlon,1)) :: scmpsw + real(kind=kind_phys), parameter :: rad2dg = 180.0_kind_phys/pi +! logical :: lprnt +! integer :: ipt ! logical effr_in ! data effr_in/.false./ ! @@ -1295,6 +1298,25 @@ subroutine GFS_radiation_driver & raddt = min(Model%fhswr, Model%fhlwr) ! print *,' in grrad : raddt=',raddt + +! lprnt = .false. + +! do i=1,im +! lprnt = Model%kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-102.65) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-0.12) < 0.201 +! lprnt = Model%kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-184.00) < 0.301 & +! .and. abs(grid%xlat(i)*rad2dg-83.23) < 0.301 +! if (kdt == 1) & +! write(2000+me,*)' i=',i,' xlon=',grid%xlon(i)*rad2dg, +! & +! ' xlat=',grid%xlat(i)*rad2dg,' me=',me +! if (lprnt) then +! ipt = i +! write(0,*)' ipt=',ipt,'xlon=',grid%xlon(i)*rad2dg,' xlat=',grid%xlat(i)*rad2dg,' me=',me +! exit +! endif +! enddo + !> -# Setup surface ground temperature and ground/air skin temperature !! if required. @@ -1857,7 +1879,7 @@ subroutine GFS_radiation_driver & !> - Call module_radsw_main::swrad(), to compute SW heating rates and !! fluxes. ! print *,' in grrad : calling swrad' - + if (Model%swhtr) then call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs gasvmr, clouds, Tbd%icsdsw, faersw, & diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 5da588a48..8f577463e 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -241,6 +241,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: zorl (:) => null() !< composite surface roughness in cm real (kind=kind_phys), pointer :: zorlo (:) => null() !< ocean surface roughness in cm real (kind=kind_phys), pointer :: zorll (:) => null() !< land surface roughness in cm + real (kind=kind_phys), pointer :: zorli (:) => null() !< ice surface roughness in cm real (kind=kind_phys), pointer :: fice (:) => null() !< ice fraction over open water grid ! real (kind=kind_phys), pointer :: hprim (:) => null() !< topographic standard deviation in m real (kind=kind_phys), pointer :: hprime (:,:) => null() !< orographic metrics @@ -2177,6 +2178,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate (Sfcprop%zorl (IM)) allocate (Sfcprop%zorlo (IM)) allocate (Sfcprop%zorll (IM)) + allocate (Sfcprop%zorli (IM)) allocate (Sfcprop%fice (IM)) ! allocate (Sfcprop%hprim (IM)) allocate (Sfcprop%hprime (IM,Model%nmtvr)) @@ -2194,6 +2196,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%zorl = clear_val Sfcprop%zorlo = clear_val Sfcprop%zorll = clear_val + Sfcprop%zorli = clear_val Sfcprop%fice = clear_val ! Sfcprop%hprim = clear_val Sfcprop%hprime = clear_val diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 925e96397..67c2da461 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -527,6 +527,13 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys [fice] standard_name = sea_ice_concentration long_name = ice fraction over open water @@ -3397,14 +3404,14 @@ [min_lakeice] standard_name = lake_ice_minimum long_name = minimum lake ice value - units = ??? + units = frac dimensions = () type = real kind = kind_phys [min_seaice] standard_name = sea_ice_minimum long_name = minimum sea ice value - units = ??? + units = frac dimensions = () type = real kind = kind_phys diff --git a/gfsphysics/physics/dcyc2.f b/gfsphysics/physics/dcyc2.f index a97b428b5..196148d2b 100644 --- a/gfsphysics/physics/dcyc2.f +++ b/gfsphysics/physics/dcyc2.f @@ -276,6 +276,8 @@ subroutine dcyc2t3 & else xmu(i) = 0.0 endif +! if (lprnt .and. i == ipr) write(0,*)' in dcyc3: sfcnsw=',sfcnsw(i) +! &,' sfcdsw=',sfcdsw(i),' xmu=',xmu(i) ! --- ... adjust sfc net and downward sw fluxes for zenith angle changes ! note: sfc emiss effect will not be appied here diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index f7dae4881..8e799fb12 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -60,7 +60,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) character(len=6) :: tile_num_ch real(kind=kind_phys), parameter :: pifac=180.0/pi real(kind=kind_phys) :: sig1t, dt_warm - integer :: npts, len, nb, ix, jx, ls, ios + integer :: npts, len, nb, ix, jx, ls, ios, ll logical :: exists ! !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @@ -237,9 +237,11 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%alnsf (ix) = ALBFC1 (len + npts*2) Sfcprop(nb)%alnwf (ix) = ALBFC1 (len + npts*3) do ls = 1,Model%lsoil - Sfcprop(nb)%smc (ix,ls) = SMCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%stc (ix,ls) = STCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%slc (ix,ls) = SLCFC1 (len + (ls-1)*npts) + ll = len + (ls-1)*npts + Sfcprop(nb)%smc (ix,ls) = SMCFC1 (ll) + Sfcprop(nb)%stc (ix,ls) = STCFC1 (ll) + Sfcprop(nb)%slc (ix,ls) = SLCFC1 (ll) + if (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (ll) enddo ENDDO !-----END BLOCK SIZE LOOP------------------------------ ENDDO !-----END BLOCK LOOP------------------------------- diff --git a/gfsphysics/physics/radiation_surface.f b/gfsphysics/physics/radiation_surface.f index e02ea32b9..99f0ebc2f 100644 --- a/gfsphysics/physics/radiation_surface.f +++ b/gfsphysics/physics/radiation_surface.f @@ -609,7 +609,7 @@ subroutine setalb & ab1bm = min(0.99, alnsf(i)*rfcs) ab2bm = min(0.99, alvsf(i)*rfcs) sfcalb(i,1) = ab1bm *flnd + asenb*fsea + asnnb*fsno - sfcalb(i,2) = alnwf(i) *flnd + asend*fsea + asnnd*fsno + sfcalb(i,2) = alnwf(i)*flnd + asend*fsea + asnnd*fsno sfcalb(i,3) = ab2bm *flnd + asevb*fsea + asnvb*fsno sfcalb(i,4) = alvwf(i) *flnd + asevd*fsea + asnvd*fsno @@ -620,7 +620,7 @@ subroutine setalb & ! sfc-perts, mgehne *** ! perturb all 4 kinds of surface albedo, sfcalb(:,1:4) - if (pertalb(1)>0.0) then + if (pertalb(1) > 0.0) then do i = 1, imax do kk=1, 4 ! compute beta distribution parameters for all 4 albedos diff --git a/gfsphysics/physics/sfc_diff.f b/gfsphysics/physics/sfc_diff.f index f150cdfc4..c807595c5 100644 --- a/gfsphysics/physics/sfc_diff.f +++ b/gfsphysics/physics/sfc_diff.f @@ -23,7 +23,6 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) ! -------- -------- --------- integer, intent(in) :: im, ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean - integer, dimension(im), intent(in) :: vegtype logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -187,7 +186,6 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) ztmax = z0max*exp( - tem1*tem1 & * czilc*ca*sqrt(ustar(i,2)*(0.01/1.5e-05))) ztmax = max(ztmax, 1.0e-6) ->>>>>>> upstream/develop ! call stability ! --- inputs: diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 918ebb457..7e8ebccba 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -504,7 +504,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !--- local variables for sncovr calculation integer :: vegtyp logical :: mand - real(kind=kind_phys) :: rsnow, tem + real(kind=kind_phys) :: rsnow, tem, tem1 !--- Noah MP integer :: soiltyp,ns,imon,iter,imn real(kind=kind_phys) :: masslai, masssai,snd @@ -633,7 +633,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo - if (Model%cplflx .or. Model%frac_grid) then ! needs more variables + if (Model%frac_grid) then ! needs more variables + nvar_s2m = 35 + elseif (Model%cplflx) then ! needs more variables nvar_s2m = 34 else nvar_s2m = 32 @@ -661,6 +663,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) allocate(sfc_name3(0:nvar_s3+nvar_s3mp)) allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp)) + allocate(sfc_var3ice(nx,ny,Model%kice)) allocate(sfc_var3(nx,ny,Model%lsoil,nvar_s3)) #endif sfc_var2 = -9999.0_r8 @@ -710,9 +713,10 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) sfc_name2(31) = 'snoalb' !--- variables below here are optional sfc_name2(32) = 'sncovr' - if(Model%cplflx) then + if(Model%cplflx .or. Model%frac_grid) then sfc_name2(33) = 'tsfcl' !temp on land portion of a cell sfc_name2(34) = 'zorll' !zorl on land portion of a cell + sfc_name2(35) = 'zorli' !zorl on land portion of a cell end if !--- NSSTM inputs only needed when (nstf_name(1) > 0) .and. (nstf_name(2)) == 0) @@ -786,7 +790,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !--- register the 2D fields do num = 1,nvar_s2m var2_p => sfc_var2(:,:,num) - if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll') then + if (trim(sfc_name2(num)) == 'sncovr'.or. trim(sfc_name2(num)) == 'tsfcl' .or. trim(sfc_name2(num)) == 'zorll' .or. trim(sfc_name2(num)) == 'zorli') then id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain, mandatory=.false.) else id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain) @@ -901,6 +905,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) call mpp_error(NOTE,'reading surface properties data from INPUT/sfc_data.tile*.nc') call restore_state(Sfc_restart) +! write(0,*)' stype read in min,max=',minval(sfc_var2(:,:,35)),maxval(sfc_var2(:,:,35)),' sfc_name2=',sfc_name2(35) ! write(0,*)' stype read in min,max=',minval(sfc_var2(:,:,18)),maxval(sfc_var2(:,:,18)) ! write(0,*)' sfc_var2=',sfc_var2(:,:,12) @@ -949,17 +954,18 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if(Model%cplflx .or. Model%frac_grid) then Sfcprop(nb)%tsfcl(ix) = sfc_var2(i,j,33) !--- sfcl (temp on land portion of a cell) Sfcprop(nb)%zorll(ix) = sfc_var2(i,j,34) !--- zorll (zorl on land portion of a cell) - end if + Sfcprop(nb)%zorli(ix) = sfc_var2(i,j,35) !--- zorll (zorl on ice portion of a cell) + endif if(Model%frac_grid) then ! obtain slmsk from landfrac !! next 5 lines are temporary till lake model is available if (Sfcprop(nb)%lakefrac(ix) > zero) then - Sfcprop(nb)%lakefrac(ix) = nint(Sfcprop(nb)%lakefrac(ix)) +! Sfcprop(nb)%lakefrac(ix) = nint(Sfcprop(nb)%lakefrac(ix)) Sfcprop(nb)%landfrac(ix) = one - Sfcprop(nb)%lakefrac(ix) if (Sfcprop(nb)%lakefrac(ix) == zero) Sfcprop(nb)%fice(ix) = zero - end if + endif Sfcprop(nb)%slmsk(ix) = ceiling(Sfcprop(nb)%landfrac(ix)) - if (Sfcprop(nb)%fice(ix) > zero .and. Sfcprop(nb)%landfrac(ix) == zero) Sfcprop(nb)%slmsk(ix) = 2 ! land dominates ice if co-exist + if (Sfcprop(nb)%fice(ix) > Model%min_lakeice .and. Sfcprop(nb)%landfrac(ix) == zero) Sfcprop(nb)%slmsk(ix) = 2 ! land dominates ice if co-exist else ! obtain landfrac from slmsk if (Sfcprop(nb)%slmsk(ix) > 1.9_r8) then Sfcprop(nb)%landfrac(ix) = zero @@ -970,10 +976,16 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if (Sfcprop(nb)%lakefrac(ix) > zero) then Sfcprop(nb)%oceanfrac(ix) = zero ! lake & ocean don't coexist in a cell - if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) Sfcprop(nb)%fice(ix) = zero + if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) then + Sfcprop(nb)%fice(ix) = zero + if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 + endif else Sfcprop(nb)%oceanfrac(ix) = one - Sfcprop(nb)%landfrac(ix) - if (Sfcprop(nb)%fice(ix) < Model%min_seaice) Sfcprop(nb)%fice(ix) = zero + if (Sfcprop(nb)%fice(ix) < Model%min_seaice) then + Sfcprop(nb)%fice(ix) = zero + if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 + endif endif ! !--- NSSTM variables @@ -1204,9 +1216,20 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo endif + + if (sfc_var2(i,j,35) < -9990.0_r8) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorli') +!$omp parallel do default(shared) private(nb, ix) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) !--- compute zorli from existing variables + enddo + enddo + endif + endif -#ifdef CCPP +!#ifdef CCPP if (nint(sfc_var3ice(1,1,1)) == -9999) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tiice') do nb = 1, Atm_block%nblks @@ -1217,30 +1240,33 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo endif -#endif +!#endif !#endif if(Model%frac_grid) then ! 3-way composite -!$omp parallel do default(shared) private(nb, ix, tem) +!$omp parallel do default(shared) private(nb, ix, tem, tem1) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) Sfcprop(nb)%tsfco(ix) = max(con_tice, Sfcprop(nb)%tsfco(ix)) - tem = (one-Sfcprop(nb)%landfrac(ix)) * Sfcprop(nb)%fice(ix) ! tem = ice fraction wrt whole cell + tem1 = one - Sfcprop(nb)%landfrac(ix) + tem = tem1 * Sfcprop(nb)%fice(ix) ! tem = ice fraction wrt whole cell Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) * Sfcprop(nb)%landfrac(ix) & - + Sfcprop(nb)%zorll(ix) * tem & !zorl ice = zorl land - + Sfcprop(nb)%zorlo(ix) * (one-Sfcprop(nb)%landfrac(ix)-tem) + + Sfcprop(nb)%zorli(ix) * tem & + + Sfcprop(nb)%zorlo(ix) * (tem1-tem) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) * Sfcprop(nb)%landfrac(ix) & + Sfcprop(nb)%tisfc(ix) * tem & - + Sfcprop(nb)%tsfco(ix) * (one-Sfcprop(nb)%landfrac(ix)-tem) + + Sfcprop(nb)%tsfco(ix) * (tem1-tem) enddo enddo else !$omp parallel do default(shared) private(nb, ix, tem) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) - !--- specify tsfcl/zorll from existing variable tsfco/zorlo + !--- specify tsfcl/zorll/zorli from existing variable tsfco/zorlo Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) + Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) enddo @@ -1548,7 +1574,9 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p2 => NULL() real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p3 => NULL() - if (Model%cplflx) then ! needs more variables + if (Model%frac_grid) then ! needs more variables + nvar2m = 35 + elseif (Model%cplflx) then ! needs more variables nvar2m = 34 else nvar2m = 32 @@ -1669,6 +1697,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta if (Model%cplflx) then sfc_name2(33) = 'tsfcl' !temp on land portion of a cell sfc_name2(34) = 'zorll' !zorl on land portion of a cell + sfc_name2(35) = 'zorli' !zorl on land portion of a cell end if !--- NSSTM inputs only needed when (nstf_name(1) > 0) .and. (nstf_name(2)) == 0) sfc_name2(nvar2m+1) = 'tref' @@ -1739,7 +1768,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta !--- register the 2D fields do num = 1,nvar2m var2_p => sfc_var2(:,:,num) - if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll') then + if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll' .or.trim(sfc_name2(num)) == 'zorli') then id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain, mandatory=.false.) else id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain) @@ -1811,7 +1840,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name3(0) = 'tiice' var3_p => sfc_var3ice(:,:,:) id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name3(0), var3_p, domain=fv_domain) - end if + endif do num = 1,nvar3 var3_p => sfc_var3(:,:,:,num) @@ -1846,10 +1875,16 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta i = Atm_block%index(nb)%ii(ix) - isc + 1 j = Atm_block%index(nb)%jj(ix) - jsc + 1 sfc_var2(i,j,1) = Sfcprop(nb)%slmsk(ix) !--- slmsk - sfc_var2(i,j,2) = Sfcprop(nb)%tsfc(ix) !--- tsfc (tsea in sfc file) + if (Model%frac_grid) then + sfc_var2(i,j,2) = Sfcprop(nb)%tsfco(ix) !--- tsfc (tsea in sfc file) + sfc_var2(i,j,5) = Sfcprop(nb)%zorlo(ix) !--- zorlo + else + sfc_var2(i,j,2) = Sfcprop(nb)%tsfc(ix) !--- tsfc (tsea in sfc file) + sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl + endif sfc_var2(i,j,3) = Sfcprop(nb)%weasd(ix) !--- weasd (sheleg in sfc file) sfc_var2(i,j,4) = Sfcprop(nb)%tg3(ix) !--- tg3 - sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl +! sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl sfc_var2(i,j,6) = Sfcprop(nb)%alvsf(ix) !--- alvsf sfc_var2(i,j,7) = Sfcprop(nb)%alvwf(ix) !--- alvwf sfc_var2(i,j,8) = Sfcprop(nb)%alnsf(ix) !--- alnsf @@ -1877,9 +1912,10 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_var2(i,j,30) = Sfcprop(nb)%slope(ix) !--- slope sfc_var2(i,j,31) = Sfcprop(nb)%snoalb(ix)!--- snoalb sfc_var2(i,j,32) = Sfcprop(nb)%sncovr(ix)!--- sncovr - if (Model%cplflx) then + if (Model%cplflx .or. Model%frac_grid) then sfc_var2(i,j,33) = Sfcprop(nb)%tsfcl(ix) !--- tsfcl (temp on land) sfc_var2(i,j,34) = Sfcprop(nb)%zorll(ix) !--- zorll (zorl on land) + sfc_var2(i,j,35) = Sfcprop(nb)%zorli(ix) !--- zorli (zorl on ice) end if !--- NSSTM variables if (Model%nstf_name(1) > 0) then From acd71f4d0aecffaafa3eeaff02dcb6e547afc804 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 10 Jul 2020 00:10:12 +0000 Subject: [PATCH 60/91] after submodule sync --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 37444dc7d..3af3d7f9b 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 37444dc7da2af9399c17c1c9bd63b100ea0fd81c +Subproject commit 3af3d7f9b1ae847662958ffbebba28e79ef23bf4 From 39cb436ea1fb6f518086202b6f9bedfc1836f3f4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 20 Jul 2020 19:03:45 +0000 Subject: [PATCH 61/91] change in gitmodules and some fixes in physics --- .gitmodules | 8 ++++---- atmos_model.F90 | 4 ++-- ccpp/framework | 2 +- ccpp/physics | 2 +- fv3_cap.F90 | 2 +- gfsphysics/GFS_layer/GFS_radiation_driver.F90 | 5 +++++ 6 files changed, 14 insertions(+), 9 deletions(-) diff --git a/.gitmodules b/.gitmodules index 0fbad50f5..b6fab7da5 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,11 +1,11 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere - branch = dev/emc + url = https://github.com/NOAA-EMC/SMoorthi-emc/GFDL_atmos_cubed_sphere + branch = SM_Jul092020 [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/NCAR/ccpp-framework - branch = master + url = https://github.com/SMoorthi-emc/ccpp-framework + branch = SM_Jul092020 [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics diff --git a/atmos_model.F90 b/atmos_model.F90 index 5668a42bc..ddb54eac9 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1761,7 +1761,7 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then + if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > 150.0) then ! IPD_Data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) IPD_Data(nb)%Sfcprop%tisfc(ix) = datar8(i,j) endif @@ -1781,7 +1781,7 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then + if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > 150.0) then ! IPD_Data(nb)%Coupling%tseain_cpl(ix) = datar8(i,j) IPD_Data(nb)%Sfcprop%tsfco(ix) = datar8(i,j) endif diff --git a/ccpp/framework b/ccpp/framework index b14e3e041..209f1c92d 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit b14e3e0415205ea4d3004bfb5241cc34da702db8 +Subproject commit 209f1c92d99b7d4cc63e0d41c652fcfd730bd9fa diff --git a/ccpp/physics b/ccpp/physics index f967360f2..21f7fddfd 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit f967360f234c77390a6e1e47d077d7b8eabd3352 +Subproject commit 21f7fddfd1885896a2ac282c093c9529b10e1bd6 diff --git a/fv3_cap.F90 b/fv3_cap.F90 index 95786b17a..d0d55b47a 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -203,7 +203,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return profile_memory = (trim(value)/="false") - call ESMF_AttributeGet(gcomp, name="DumpFields_ATM", value=value, defaultValue="false", & + call ESMF_AttributeGet(gcomp, name="DumpFields", value=value, defaultValue="false", & convention="NUOPC", purpose="Instance", rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 index 0a551ef19..ebec30c4d 100644 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 @@ -1382,6 +1382,11 @@ subroutine GFS_radiation_driver & plyr(i,k1) = 0.5d0 * (plvl(i,k1+1) + plvl(i,k1)) prslk1(i,k1) = (plyr(i,k1)*0.001d0) ** rocp enddo + else + k1 = lm + kd + do i = 1, IM + plvl(i,k1+1) = 0.01d0 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) + enddo endif endif ! From 9ed3e5247c47ee465246284835b91e206c78908e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 20 Jul 2020 20:01:11 +0000 Subject: [PATCH 62/91] after syncing .gitmodules --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index b6fab7da5..1ca0f5396 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,6 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/NOAA-EMC/SMoorthi-emc/GFDL_atmos_cubed_sphere + url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere branch = SM_Jul092020 [submodule "ccpp/framework"] path = ccpp/framework From a4a306e06200f2af1d6bfbae88ea53592d78388f Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 21 Jul 2020 19:46:26 +0000 Subject: [PATCH 63/91] after merging with fv3/develop with flake and adding a z0 update for wave/atm coupling --- .gitmodules | 2 +- atmos_model.F90 | 11 ++++++----- ccpp/physics | 2 +- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/.gitmodules b/.gitmodules index 1ca0f5396..e2f4dc77a 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,4 +9,4 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics - branch = SM_Jul092020 + branch = SM_Jul202020 diff --git a/atmos_model.F90 b/atmos_model.F90 index ddb54eac9..d32609c48 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -222,9 +222,10 @@ module atmos_model_mod logical,parameter :: flip_vc = .true. #endif - real(kind=IPD_kind_phys), parameter :: zero = 0.0_IPD_kind_phys, & - one = 1.0_IPD_kind_phys, & - epsln = 1.0e-10_IPD_kind_phys + real(kind=IPD_kind_phys), parameter :: zero = 0.0_IPD_kind_phys, & + one = 1.0_IPD_kind_phys, & + epsln = 1.0e-10_IPD_kind_phys, & + zorlmin = 1.0e-7_IPD_kind_phys contains @@ -1739,8 +1740,8 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - tem = 100.0_IPD_kind_phys * max(zero, min(0.1_IPD_kind_phys, datar8(i,j))) + if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > zorlmin) then + tem = 100.0_IPD_kind_phys * min(0.1_IPD_kind_phys, datar8(i,j)) ! IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem IPD_Data(nb)%Sfcprop%zorlo(ix) = tem diff --git a/ccpp/physics b/ccpp/physics index 21f7fddfd..20336bff8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 21f7fddfd1885896a2ac282c093c9529b10e1bd6 +Subproject commit 20336bff8cf85d5e8026ca1e4513fb2cd049d3cb From 340680232ba7bb945d8cdadb95fcb820c205f356 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 22 Jul 2020 11:11:11 +0000 Subject: [PATCH 64/91] updating fix for wave coupling issue and some other fixes related to fractional grid --- atmos_model.F90 | 3 ++ ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 2 +- gfsphysics/GFS_layer/GFS_typedefs.F90 | 3 ++ gfsphysics/GFS_layer/GFS_typedefs.meta | 7 +++ gfsphysics/physics/sfc_diff.f | 7 +-- io/FV3GFS_io.F90 | 52 ++++++++++++++++++--- 7 files changed, 64 insertions(+), 12 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index d32609c48..0b16ae69f 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1744,6 +1744,9 @@ subroutine assign_importdata(rc) tem = 100.0_IPD_kind_phys * min(0.1_IPD_kind_phys, datar8(i,j)) ! IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem IPD_Data(nb)%Sfcprop%zorlo(ix) = tem + IPD_Data(nb)%Sfcprop%zorlw(ix) = tem + else + IPD_Data(nb)%Sfcprop%zorlw(ix) = -999.0_IPD_kind_phys endif enddo diff --git a/ccpp/physics b/ccpp/physics index 20336bff8..c2c4492d1 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 20336bff8cf85d5e8026ca1e4513fb2cd049d3cb +Subproject commit c2c4492d1c137a54eae76a6aa3c83515a1e36f35 diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 9cb6de297..ff12d1953 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -1709,7 +1709,7 @@ subroutine GFS_physics_driver & Diag%u10m, Diag%v10m, Model%sfc_z0_type, & wet, dry, icy, tsfc3, tsurf3, snowd3, & ! --- input/output: - zorl3, uustar3, & + zorl3, Sfcprop%zorlw, uustar3, & ! --- outputs: cd3, cdq3, rb3, stress3, ffmm3, ffhh3, fm103, fh23) ! cd3, cdq3, rb3, stress3, ffmm3, ffhh3, fm103, fh23, wind, lprnt, ipr) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 3657b7e24..91680b8ce 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -246,6 +246,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: zorlo (:) => null() !< ocean surface roughness in cm real (kind=kind_phys), pointer :: zorll (:) => null() !< land surface roughness in cm real (kind=kind_phys), pointer :: zorli (:) => null() !< ice surface roughness in cm + real (kind=kind_phys), pointer :: zorlw (:) => null() !< wave surface roughness in cm real (kind=kind_phys), pointer :: fice (:) => null() !< ice fraction over open water grid ! real (kind=kind_phys), pointer :: hprim (:) => null() !< topographic standard deviation in m real (kind=kind_phys), pointer :: hprime (:,:) => null() !< orographic metrics @@ -2222,6 +2223,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate (Sfcprop%zorlo (IM)) allocate (Sfcprop%zorll (IM)) allocate (Sfcprop%zorli (IM)) + allocate (Sfcprop%zorlw (IM)) allocate (Sfcprop%fice (IM)) ! allocate (Sfcprop%hprim (IM)) allocate (Sfcprop%hprime (IM,Model%nmtvr)) @@ -2241,6 +2243,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%zorlo = clear_val Sfcprop%zorll = clear_val Sfcprop%zorli = clear_val + Sfcprop%zorlw = clear_val Sfcprop%fice = clear_val ! Sfcprop%hprim = clear_val Sfcprop%hprime = clear_val diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index b15b2bc5d..79dc22fd7 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -547,6 +547,13 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys +[zorlw] + standard_name = surface_roughness_length_from_wave_model + long_name = surface roughness length from wave model + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys [fice] standard_name = sea_ice_concentration long_name = ice fraction over open water diff --git a/gfsphysics/physics/sfc_diff.f b/gfsphysics/physics/sfc_diff.f index c807595c5..9b56cdd33 100644 --- a/gfsphysics/physics/sfc_diff.f +++ b/gfsphysics/physics/sfc_diff.f @@ -12,9 +12,9 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) & flag_iter,redrag, !intent(in) & u10m,v10m,sfc_z0_type, !hafs,z0 type !intent(in) & wet,dry,icy, !intent(in) - & tskin, tsurf, snwdph, z0rl, ustar, + & tskin, tsurf, snwdph, z0rl, z0rlw, ustar ! - & cm, ch, rb, stress, fm, fh, fm10, fh2) + &, cm, ch, rb, stress, fm, fh, fm10, fh2) ! use physcons, rvrdm1 => con_fvirt implicit none @@ -36,6 +36,7 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) real(kind=kind_phys), dimension(im,3), intent(in) :: & tskin, tsurf, snwdph + real(kind=kind_phys), dimension(im), intent(in) :: z0rlw real(kind=kind_phys), dimension(im,3), intent(inout) :: & z0rl, ustar @@ -267,7 +268,7 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) z0rl(i,3) = 1.0d-4 endif - elseif (z0rl(i,3) < 1.0d-7) then + elseif (z0rlw(i) < 1.0d-7) then z0 = (charnock / grav) * ustar(i,3) * ustar(i,3) if (redrag) then diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 9d903231e..95b372659 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -650,6 +650,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) else nvar_s2m = 32 endif + if (Model%cplwav) then + nvar_s2m = nvar_s2m + 1 + endif !--- deallocate containers and free restart container deallocate(oro_name2, oro_var2) @@ -803,8 +806,13 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if(Model%cplflx .or. Model%frac_grid) then sfc_name2(33) = 'tsfcl' !temp on land portion of a cell sfc_name2(34) = 'zorll' !zorl on land portion of a cell + endif + if(Model%frac_grid) then sfc_name2(35) = 'zorli' !zorl on land portion of a cell - end if + endif + if(Model%cplwav) then + sfc_name2(nvar_s2m) = 'zorlw' !zorl on land portion of a cell + endif !--- NSSTM inputs only needed when (nstf_name(1) > 0) .and. (nstf_name(2)) == 0) sfc_name2(nvar_s2m+1) = 'tref' @@ -877,7 +885,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !--- register the 2D fields do num = 1,nvar_s2m var2_p => sfc_var2(:,:,num) - if (trim(sfc_name2(num)) == 'sncovr'.or. trim(sfc_name2(num)) == 'tsfcl' .or. trim(sfc_name2(num)) == 'zorll' .or. trim(sfc_name2(num)) == 'zorli') then + if (trim(sfc_name2(num)) == 'sncovr'.or. trim(sfc_name2(num)) == 'tsfcl' .or. trim(sfc_name2(num)) == 'zorll' & + .or. trim(sfc_name2(num)) == 'zorli' .or. trim(sfc_name2(num)) == 'zorlw') then id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain, mandatory=.false.) else id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain) @@ -1041,8 +1050,13 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if(Model%cplflx .or. Model%frac_grid) then Sfcprop(nb)%tsfcl(ix) = sfc_var2(i,j,33) !--- sfcl (temp on land portion of a cell) Sfcprop(nb)%zorll(ix) = sfc_var2(i,j,34) !--- zorll (zorl on land portion of a cell) + endif + if(Model%frac_grid) then Sfcprop(nb)%zorli(ix) = sfc_var2(i,j,35) !--- zorll (zorl on ice portion of a cell) endif + if(Model%cplwav) then + Sfcprop(nb)%zorlw(ix) = sfc_var2(i,j,nvar_s2m) !--- (zorw from wave model) + endif if(Model%frac_grid) then ! obtain slmsk from landfrac !! next 5 lines are temporary till lake model is available @@ -1303,6 +1317,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo endif + endif + if (Model%frac_grid) then if (sfc_var2(i,j,35) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorli') @@ -1313,7 +1329,17 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo endif - + endif + if (Model%frac_grid) then + if (sfc_var2(i,j,nvar_s2m) < -9990.0_r8) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorli') +!$omp parallel do default(shared) private(nb, ix) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + Sfcprop(nb)%zorlw(ix) = Sfcprop(nb)%zorlo(ix) !--- compute zorlw from existing variables + enddo + enddo + endif endif !#ifdef CCPP @@ -1668,6 +1694,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta else nvar2m = 32 endif + if (Model%cplwav) nvar2m = nvar2m + 1 nvar2o = 18 #ifdef CCPP if (Model%lsm == Model%lsm_ruc) then @@ -1781,11 +1808,16 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name2(31) = 'snoalb' !--- variables below here are optional sfc_name2(32) = 'sncovr' - if (Model%cplflx) then + if (Model%cplflx .or. Model%frac_grid) then sfc_name2(33) = 'tsfcl' !temp on land portion of a cell sfc_name2(34) = 'zorll' !zorl on land portion of a cell + endif + if (Model%frac_grid) then sfc_name2(35) = 'zorli' !zorl on land portion of a cell - end if + endif + if (Model%cplwav) then + sfc_name2(nvar2m) = 'zorlw' !zorl on land portion of a cell + endif !--- NSSTM inputs only needed when (nstf_name(1) > 0) .and. (nstf_name(2)) == 0) sfc_name2(nvar2m+1) = 'tref' sfc_name2(nvar2m+2) = 'z_c' @@ -1855,7 +1887,8 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta !--- register the 2D fields do num = 1,nvar2m var2_p => sfc_var2(:,:,num) - if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll' .or.trim(sfc_name2(num)) == 'zorli') then + if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll' & + .or.trim(sfc_name2(num)) == 'zorli' .or.trim(sfc_name2(num)) == 'zorlw') then id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain, mandatory=.false.) else id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain) @@ -2002,8 +2035,13 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta if (Model%cplflx .or. Model%frac_grid) then sfc_var2(i,j,33) = Sfcprop(nb)%tsfcl(ix) !--- tsfcl (temp on land) sfc_var2(i,j,34) = Sfcprop(nb)%zorll(ix) !--- zorll (zorl on land) + endif + if (Model%frac_grid) then sfc_var2(i,j,35) = Sfcprop(nb)%zorli(ix) !--- zorli (zorl on ice) - end if + endif + if (Model%cplwav) then + sfc_var2(i,j,nvar2m) = Sfcprop(nb)%zorli(ix) !--- zorlw (zorl from wav) + endif !--- NSSTM variables if (Model%nstf_name(1) > 0) then sfc_var2(i,j,nvar2m+1) = Sfcprop(nb)%tref(ix) !--- nsstm tref From 908b8f264e9b0ee6174f8dc8b22b5f1542fca17a Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 22 Jul 2020 11:12:48 +0000 Subject: [PATCH 65/91] updating gitmodules --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index e2f4dc77a..7e60a274c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,4 +9,4 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics - branch = SM_Jul202020 + branch = SM_Jul212020 From 03004a999ea9ad488ac2553f08cfe36f3349d889 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 24 Jul 2020 01:45:26 +0000 Subject: [PATCH 66/91] After merging with fv3atm/develop and updating to latest dynamics --- .gitmodules | 2 +- atmos_model.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index 7e60a274c..491629970 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,7 +1,7 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere - branch = SM_Jul092020 + branch = SM_Jul232020 [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/SMoorthi-emc/ccpp-framework diff --git a/atmos_model.F90 b/atmos_model.F90 index 0b16ae69f..1300f9251 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -78,7 +78,7 @@ module atmos_model_mod use atmosphere_mod, only: atmosphere_scalar_field_halo use atmosphere_mod, only: atmosphere_get_bottom_layer use atmosphere_mod, only: set_atmosphere_pelist -use atmosphere_mod, only: Atm, mytile +use atmosphere_mod, only: Atm, mygrid use block_control_mod, only: block_control_type, define_blocks_packed use DYCORE_typedefs, only: DYCORE_data_type, DYCORE_diag_type #ifdef CCPP @@ -632,8 +632,8 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) Init_parm%area => Atmos%area Init_parm%tracer_names => tracer_names #ifdef CCPP - Init_parm%restart = Atm(mytile)%flagstruct%warm_start - Init_parm%hydrostatic = Atm(mytile)%flagstruct%hydrostatic + Init_parm%restart = Atm(mygrid)%flagstruct%warm_start + Init_parm%hydrostatic = Atm(mygrid)%flagstruct%hydrostatic #endif #ifdef INTERNAL_FILE_NML @@ -694,7 +694,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) endif endif - Atm(mytile)%flagstruct%do_skeb = IPD_Control%do_skeb + Atm(mygrid)%flagstruct%do_skeb = IPD_Control%do_skeb ! initialize the IAU module call iau_initialize (IPD_Control,IAU_data,Init_parm) @@ -715,7 +715,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) call FV3GFS_diag_register (IPD_Diag, Time, Atm_block, IPD_Control, Atmos%lon, Atmos%lat, Atmos%axes) call IPD_initialize_rst (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) #ifdef CCPP - call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain, Atm(mytile)%flagstruct%warm_start) + call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain, Atm(mygrid)%flagstruct%warm_start) #else call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain) #endif From a7a306cef114059adcacf1844257e6a8eca56205 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Jul 2020 17:07:57 +0000 Subject: [PATCH 67/91] replacing post_gfs.F90 with develop version - note that this will NOT work with MG3 --- io/post_gfs.F90 | 922 +++++++++++++++++++++++------------------------- 1 file changed, 442 insertions(+), 480 deletions(-) diff --git a/io/post_gfs.F90 b/io/post_gfs.F90 index 248ce6d06..76dd0251c 100644 --- a/io/post_gfs.F90 +++ b/io/post_gfs.F90 @@ -112,20 +112,19 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & !----------------------------------------------------------------------- ! ! if(mype==0) print *,'in post_run,be post_alctvars, dim=',wrt_int_state%im, & -! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & -! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & +! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & +! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & ! 'jstagrp=',jstagrp,'jendgrp=',jendgrp - - call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & - wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & - mpicomp,jts,jte,jstagrp,jendgrp) + call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & + wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & + mpicomp,jts,jte,jstagrp,jendgrp) ! !----------------------------------------------------------------------- !*** read namelist for pv,th,po !----------------------------------------------------------------------- ! - log_postalct = .true. - first_grbtbl = .true. + log_postalct = .true. + first_grbtbl = .true. read_postcntrl = .true. ! ENDIF @@ -138,16 +137,16 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & ifmin = mynfmin if (ifhr == 0 ) ifmin = 0 if(mype==0) print *,'bf set_postvars,ifmin=',ifmin,'ifhr=',ifhr - setvar_atmfile = .false. - setvar_sfcfile = .false. + setvar_atmfile=.false. + setvar_sfcfile=.false. call set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & - setvar_sfcfile) + setvar_sfcfile) ! print *,'af set_postvars,setvar_atmfile=',setvar_atmfile, & ! 'setvar_sfcfile=',setvar_sfcfile ! if (setvar_atmfile.and.setvar_sfcfile) then -! 20190807 need to call microinit only for Ferrier microphysics +! 20190807 no need to call microinit for GFDLMP ! call MICROINIT ! if(grib=="grib2" .and. read_postcntrl) then @@ -240,62 +239,66 @@ subroutine post_getattr_gfs(wrt_int_state, fldbundle) ! look at the field bundle attributes call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, Count=attcount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__,file=__FILE__))return ! bail out ! aklen=0. do i=1, attCount - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & - typekind=typekind, itemCount=n, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return + call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & + attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & + typekind=typekind, itemCount=n, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__,file=__FILE__))return ! bail out if (typekind==ESMF_TYPEKIND_I4 ) then - if(n == 1) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, rc=rc) - if (trim(attName) == 'ncnsto') wrt_int_state%ntrac = varival - if (trim(attName) == 'ncld') wrt_int_state%ncld = varival - if (trim(attName) == 'nsoil') wrt_int_state%nsoil = varival - if (trim(attName) == 'fhzero') wrt_int_state%fhzero = varival - if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics = varival + name=trim(attName), value=varival, rc=rc) + if (trim(attName) == 'ncnsto') wrt_int_state%ntrac=varival + if (trim(attName) == 'ncld') wrt_int_state%ncld=varival + if (trim(attName) == 'nsoil') wrt_int_state%nsoil=varival + if (trim(attName) == 'fhzero') wrt_int_state%fhzero=varival + if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics=varival endif - else if (typekind == ESMF_TYPEKIND_R4) then - if(n == 1) then + else if (typekind==ESMF_TYPEKIND_R4) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr4val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + name=trim(attName), value=varr4val, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr4val endif - else if(n > 1) then + else if(n>1) then if(trim(attName) =="ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 - else if(trim(attName) == "bk") then + else if(trim(attName) =="bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) allocate(wrt_int_state%bk(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%bk, rc=rc) + name=trim(attName), valueList=wrt_int_state%bk, rc=rc) endif endif - else if (typekind == ESMF_TYPEKIND_R8) then - if(n == 1) then + else if (typekind==ESMF_TYPEKIND_R8) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & name=trim(attName), value=varr8val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr8val endif - else if(n > 1) then - if(trim(attName) == "ak") then + else if(n>1) then + if(trim(attName) =="ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 else if(trim(attName) =="bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) @@ -329,8 +332,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use vrbls3d, only: t, q, uh, vh, wh, alpint, dpres, zint, zmid, o3, & qqr, qqs, cwm, qqi, qqw, qqg, omga, cfr, pmid, & q2, rlwtt, rswtt, tcucn, tcucns, train, el_pbl, & - pint, exch_h, ref_10cm, & - qqnw, qqni, qqnr, qqns, qqng + pint, exch_h, ref_10cm use vrbls2d, only: f, pd, sigt4, fis, pblh, ustar, z0, ths, qs, twbs,& qwbs, avgcprate, cprate, avgprec, prec, lspa, sno,& cldefi, th10, q10, tshltr, pshltr, tshltr, albase,& @@ -358,11 +360,11 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use soil, only: sldpth, sh2o, smc, stc use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice use ctlblk_mod, only: im, jm, lm, lp1, jsta, jend, jsta_2l, jend_2u, jsta_m,jend_m, & - lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & - tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & + lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & + tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & ardlw, ardsw, asrfc, avrain, avcnvc, iSF_SURFACE_PHYSICS,& - td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & - alsl, spl, ihrst + td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & + alsl, spl, ihrst use params_mod, only: erad, dtr, capa, p1000 use gridspec_mod,only: latstart, latlast, lonstart, lonlast, cenlon, cenlat use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, & @@ -387,12 +389,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! !----------------------------------------------------------------------- ! - integer i, ip1, j, l, ll, k, n, iret, ibdl, rc, kstart, kend + integer i, ip1, j, l, k, n, iret, ibdl, rc, kstart, kend integer ista,iend,fieldDimCount,gridDimCount,ncount_field integer jdate(8) logical foundland, foundice, found real(4) rinc(5) - real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp, dtq2001 + real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp real, dimension(:),allocatable :: ak5, bk5 real(4),dimension(:,:),pointer :: arrayr42d real(8),dimension(:,:),pointer :: arrayr82d @@ -471,7 +473,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & end do ! ! GFS does not output PD - pt = ak5(1) + pt = ak5(1) ! GFS may not have model derived radar ref. ! TKE @@ -482,7 +484,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & do j=jsta,jend do i=1,im ref_10cm(i,j,l) = SPVAL - q2(i,j,l) = SPVAL + q2(i,j,l) = SPVAL cfr(i,j,l) = SPVAL enddo enddo @@ -494,10 +496,10 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none),private(i,j),shared(jsta,jend,im,spval,qs,twbs,qwbs,ths) do j=jsta,jend do i=1,im - qs(i,j) = SPVAL + qs(i,j) = SPVAL twbs(i,j) = SPVAL qwbs(i,j) = SPVAL - ths(i,j) = SPVAL + ths(i,j) = SPVAL enddo enddo @@ -505,7 +507,6 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & dtq2 = wrt_int_state%dtp nphs = 2. dt = dtq2/nphs - dtq2001 = dtq2*0.001 ! ! GFS does not have convective cloud efficiency ! similated precip @@ -513,16 +514,22 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! 10 m humidity ! snow free albedo !$omp parallel do default(none), private(i,j), shared(jsta,jend,im,spval), & -!$omp& shared(cldefi,lspa,th10,q10,albase,cprate) +!$omp& shared(cldefi,lspa,th10,q10,albase) do j=jsta,jend do i=1,im cldefi(i,j) = SPVAL - lspa(i,j) = SPVAL - th10(i,j) = SPVAL - q10(i,j) = SPVAL + lspa(i,j) = SPVAL + th10(i,j) = SPVAL + q10(i,j) = SPVAL albase(i,j) = SPVAL + enddo + enddo - cprate(i,j) = 0.0 ! GFS does not have convective precip ???? +! GFS does not have convective precip +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,cprate) + do j=jsta,jend + do i=1,im + cprate(i,j) = 0. enddo enddo @@ -597,7 +604,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp& shared(rlwtt,rswtt,tcucn,tcucns,train) do j=jsta_2l,jend_2u do i=1,im - rlwtt(i,j,l) = spval + rlwtt(i,j,l) = spval rswtt(i,j,l) = spval tcucn(i,j,l) = spval tcucns(i,j,l) = spval @@ -713,19 +720,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find lans sea mask found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),fieldName='land',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'ibdl=',ibdl,'land, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'land',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) -!$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) + !$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) do j=jsta, jend do i=ista, iend if (arrayr42d(i,j) /= spval) sm(i,j) = 1.- arrayr42d(i,j) @@ -737,17 +744,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find ice fraction found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'ibdl=',ibdl,'ice, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) do j=jsta, jend do i=ista, iend sice(i,j) = arrayr42d(i,j) @@ -759,8 +768,9 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo get_lsmsk if (.not.foundland .or. .not.foundice) then - rc = 999 - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + rc=999 + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out endif if(mype==0) print *,'after find sm and sice,imp_physics=',imp_physics,'nbdl=',wrt_int_state%FBCount ! @@ -768,27 +778,29 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! ! get grid dimension count ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl,'idim=', & -! ista,iend,'jdim=',jsta,jend +! ista,iend,'jdim=',jsta,jend call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), grid=wrtGrid, & - fieldCount=ncount_field, name=wrtFBName,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + fieldCount=ncount_field, name=wrtFBName,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'in setvar, allocate fcstField,ibdl=',ibdl,'count=',ncount_field,'wrtFBname=',trim(wrtFBName) allocate(fcstField(ncount_field)) call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), & - fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl, 'nfield=',ncount_field - do n=1, ncount_field ! call ESMF_FieldGet(fcstField(n),typekind=typekind, name=fieldname, & - dimCount=fieldDimCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + dimCount=fieldDimCount,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (index(trim(fieldname),"vector") >0) cycle ! !** for 2D fields @@ -796,14 +808,14 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr82d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out allocate( arrayr42d(ista:iend,jsta:jend)) -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) do j=jsta, jend do i=ista, iend arrayr42d(i,j) = arrayr82d(i,j) @@ -812,58 +824,58 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! Terrain height (*G later) - if(trim(fieldname) == 'hgtsfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) + if(trim(fieldname)=='hgtsfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) do j=jsta,jend do i=ista, iend - fis(i,j) = arrayr42d(i,j) + fis(i,j)=arrayr42d(i,j) enddo enddo endif ! Surface pressure ! if(trim(fieldname)=='pressfc') then -!!$omp parallel do private(i,j) +! !$omp parallel do private(i,j) ! do j=jsta,jend ! do i=ista, iend -! pint(i,j) = arrayr42d(i,j) +! pint(i,j)=arrayr42d(i,j) ! enddo ! enddo ! endif ! PBL height using nemsio - if(trim(fieldname) == 'hpbl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) + if(trim(fieldname)=='hpbl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) do j=jsta,jend do i=ista, iend - pblh(i,j) = arrayr42d(i,j) + pblh(i,j)=arrayr42d(i,j) enddo enddo endif ! frictional velocity - if(trim(fieldname) == 'fricv') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) + if(trim(fieldname)=='fricv') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) do j=jsta,jend do i=ista, iend - ustar(i,j) = arrayr42d(i,j) + ustar(i,j)=arrayr42d(i,j) enddo enddo endif ! roughness length - if(trim(fieldname) == 'sfcr') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) + if(trim(fieldname)=='sfcr') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) do j=jsta,jend do i=ista, iend - z0(i,j) = arrayr42d(i,j) + z0(i,j)=arrayr42d(i,j) enddo enddo endif ! sfc exchange coeff - if(trim(fieldname) == 'sfexc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) + if(trim(fieldname)=='sfexc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) do j=jsta,jend do i=ista, iend sfcexc(i,j)=arrayr42d(i,j) @@ -872,18 +884,18 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! aerodynamic conductance - if(trim(fieldname) == 'acond') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) + if(trim(fieldname)=='acond') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) do j=jsta,jend do i=ista, iend - acond(i,j) = arrayr42d(i,j) + acond(i,j)=arrayr42d(i,j) enddo enddo endif ! surface potential T - if(trim(fieldname) == 'tmpsfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) + if(trim(fieldname)=='tmpsfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -894,114 +906,114 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! convective precip in m per physics time step - if(trim(fieldname) == 'cpratb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate) + if(trim(fieldname)=='cpratb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) & - avgcprate(i,j) = arrayr42d(i,j) * dtq2001 + avgcprate(i,j) = arrayr42d(i,j) * (dtq2*0.001) enddo enddo endif ! continuous bucket convective precip in m per physics time step - if(trim(fieldname) =='cprat_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate_cont) + if(trim(fieldname)=='cprat_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgcprate_cont(i,j) = arrayr42d(i,j) * dtq2001 + avgcprate_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! time averaged bucketed precip rate - if(trim(fieldname) == 'prateb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec) + if(trim(fieldname)=='prateb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec(i,j) = arrayr42d(i,j) * dtq2001 + avgprec(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! time averaged continuous precip rate in m per physics time step - if(trim(fieldname) == 'prate_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec_cont) + if(trim(fieldname)=='prate_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec_cont(i,j) = arrayr42d(i,j) * dtq2001 + avgprec_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! precip rate in m per physics time step - if(trim(fieldname) == 'tprcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,prec) + if(trim(fieldname)=='tprcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,prec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - prec(i,j) = arrayr42d(i,j) * (dtq2001 * 1000./dtp) + prec(i,j) = arrayr42d(i,j) * (dtq2*0.001) * 1000./dtp endif enddo enddo endif ! convective precip rate in m per physics time step - if(trim(fieldname) == 'cnvprcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,cprate) + if(trim(fieldname)=='cnvprcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,cprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2001 * 1000./dtp) + cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2*0.001) * 1000./dtp endif enddo enddo endif ! inst snow water eqivalent - if(trim(fieldname) == 'weasd') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) + if(trim(fieldname)=='weasd') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend sno(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) sno(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j)==0.)sno(i,j) = spval enddo enddo endif ! ave snow cover - if(trim(fieldname) == 'snowc_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) + if(trim(fieldname)=='snowc_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend snoavg(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) snoavg(i,j) = spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j) = spval if (snoavg(i,j) /= spval) snoavg(i,j) = snoavg(i,j)/100. enddo enddo endif ! snow depth in mm - if(trim(fieldname) == 'snod') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) + if(trim(fieldname)=='snod') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend si(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) si(i,j)=spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 enddo enddo endif ! 2m potential T (computed later) - if(trim(fieldname) == 'tmp2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) + if(trim(fieldname)=='tmp2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) do j=jsta,jend do i=ista, iend tshltr(i,j) = arrayr42d(i,j) @@ -1010,8 +1022,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! surface potential T - if(trim(fieldname) == 'spfh2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) + if(trim(fieldname)=='spfh2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) do j=jsta,jend do i=ista, iend qshltr(i,j) = arrayr42d(i,j) @@ -1020,8 +1032,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! mid day avg albedo in fraction - if(trim(fieldname) == 'albdo_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) + if(trim(fieldname)=='albdo_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) do j=jsta,jend do i=ista, iend avgalbedo(i,j) = arrayr42d(i,j) @@ -1033,8 +1045,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname) == 'tcdc_aveclm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) + if(trim(fieldname)=='tcdc_aveclm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) do j=jsta,jend do i=ista, iend avgtcdc(i,j) = arrayr42d(i,j) @@ -1046,8 +1058,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! maximum snow albedo in fraction - if(trim(fieldname) == 'snoalb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) + if(trim(fieldname)=='snoalb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) do j=jsta,jend do i=ista, iend mxsnal(i,j) = arrayr42d(i,j) @@ -1059,8 +1071,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave high cloud fraction - if(trim(fieldname) == 'tcdc_avehcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) + if(trim(fieldname)=='tcdc_avehcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) do j=jsta,jend do i=ista, iend avgcfrach(i,j) = arrayr42d(i,j) @@ -1072,8 +1084,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave low cloud fraction - if(trim(fieldname) == 'tcdc_avelcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) + if(trim(fieldname)=='tcdc_avelcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracl(i,j) = arrayr42d(i,j) @@ -1085,8 +1097,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave middle cloud fraction - if(trim(fieldname) == 'tcdc_avemcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) + if(trim(fieldname)=='tcdc_avemcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracm(i,j) = arrayr42d(i,j) @@ -1098,8 +1110,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst convective cloud fraction - if(trim(fieldname) == 'tcdccnvcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) + if(trim(fieldname)=='tcdccnvcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) do j=jsta,jend do i=ista, iend cnvcfr(i,j) = arrayr42d(i,j) @@ -1111,8 +1123,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! slope type - if(trim(fieldname) == 'sltyp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) + if(trim(fieldname)=='sltyp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1125,8 +1137,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname) == 'cnwat') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) + if(trim(fieldname)=='cnwat') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) do j=jsta,jend do i=ista, iend cmc(i,j) = arrayr42d(i,j) @@ -1137,8 +1149,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! frozen precip fraction - if(trim(fieldname) == 'cpofp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) + if(trim(fieldname)=='cpofp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -1152,8 +1164,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sea ice skin temperature - if(trim(fieldname) == 'tisfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) + if(trim(fieldname)=='tisfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) do j=jsta,jend do i=ista,iend if (arrayr42d(i,j) /= spval) then @@ -1167,8 +1179,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation fraction - if(trim(fieldname) == 'veg') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) + if(trim(fieldname)=='veg') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) do j=jsta,jend do i=ista, iend vegfrc(i,j) = arrayr42d(i,j) @@ -1183,8 +1195,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,1) = arrayr42d(i,j) @@ -1194,8 +1206,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,2) = arrayr42d(i,j) @@ -1205,8 +1217,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,3) = arrayr42d(i,j) @@ -1216,8 +1228,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,4) = arrayr42d(i,j) @@ -1227,8 +1239,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,1) = arrayr42d(i,j) @@ -1238,8 +1250,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,2) = arrayr42d(i,j) @@ -1249,8 +1261,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,3) = arrayr42d(i,j) @@ -1260,8 +1272,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,4) = arrayr42d(i,j) @@ -1271,8 +1283,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,1) = arrayr42d(i,j) @@ -1283,8 +1295,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,2) = arrayr42d(i,j) @@ -1295,8 +1307,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,3) = arrayr42d(i,j) @@ -1307,8 +1319,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,4) = arrayr42d(i,j) @@ -1320,7 +1332,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged incoming sfc longwave if(trim(fieldname)=='dlwrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) do j=jsta,jend do i=ista, iend alwin(i,j) = arrayr42d(i,j) @@ -1329,8 +1341,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc longwave - if(trim(fieldname) == 'dlwrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) + if(trim(fieldname)=='dlwrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) do j=jsta,jend do i=ista, iend rlwin(i,j) = arrayr42d(i,j) @@ -1339,8 +1351,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc longwave, CLDRAD puts a minus sign - if(trim(fieldname) == 'ulwrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) + if(trim(fieldname)=='ulwrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) do j=jsta,jend do i=ista, iend alwout(i,j) = arrayr42d(i,j) @@ -1350,8 +1362,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc longwave - if(trim(fieldname) == 'ulwrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) + if(trim(fieldname)=='ulwrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) do j=jsta,jend do i=ista, iend radot(i,j) = arrayr42d(i,j) @@ -1360,8 +1372,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing model top longwave - if(trim(fieldname) == 'ulwrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) + if(trim(fieldname)=='ulwrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) do j=jsta,jend do i=ista, iend alwtoa(i,j) = arrayr42d(i,j) @@ -1370,8 +1382,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc shortwave - if(trim(fieldname) == 'dswrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) + if(trim(fieldname)=='dswrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) do j=jsta,jend do i=ista, iend aswin(i,j) = arrayr42d(i,j) @@ -1380,8 +1392,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc shortwave - if(trim(fieldname) == 'dswrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) + if(trim(fieldname)=='dswrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) do j=jsta,jend do i=ista, iend rswin(i,j) = arrayr42d(i,j) @@ -1390,8 +1402,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc uv-b - if(trim(fieldname) == 'duvb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) + if(trim(fieldname)=='duvb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) do j=jsta,jend do i=ista, iend auvbin(i,j) = arrayr42d(i,j) @@ -1400,8 +1412,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc clear sky uv-b - if(trim(fieldname) == 'cduvb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) + if(trim(fieldname)=='cduvb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) do j=jsta,jend do i=ista, iend auvbinc(i,j) = arrayr42d(i,j) @@ -1410,8 +1422,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc shortwave,CLDRAD puts a minus sign - if(trim(fieldname) == 'uswrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) + if(trim(fieldname)=='uswrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) do j=jsta,jend do i=ista, iend aswout(i,j) = arrayr42d(i,j) @@ -1421,8 +1433,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc shortwave - if(trim(fieldname) == 'uswrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) + if(trim(fieldname)=='uswrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) do j=jsta,jend do i=ista, iend rswout(i,j) = arrayr42d(i,j) @@ -1431,8 +1443,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged model top incoming shortwave - if(trim(fieldname) == 'dswrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) + if(trim(fieldname)=='dswrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) do j=jsta,jend do i=ista, iend aswintoa(i,j) = arrayr42d(i,j) @@ -1441,8 +1453,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ime averaged model top outgoing shortwave - if(trim(fieldname) == 'uswrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) + if(trim(fieldname)=='uswrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) do j=jsta,jend do i=ista, iend aswtoa(i,j) = arrayr42d(i,j) @@ -1452,8 +1464,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface sensible heat flux, multiplied by -1 because ! wrf model fluxhas reversed sign convention using gfsio - if(trim(fieldname) == 'shtfl_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) + if(trim(fieldname)=='shtfl_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) do j=jsta,jend do i=ista, iend sfcshx(i,j) = arrayr42d(i,j) @@ -1463,8 +1475,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface sensible heat flux - if(trim(fieldname) == 'shtfl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) + if(trim(fieldname)=='shtfl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) do j=jsta,jend do i=ista, iend twbs(i,j) = arrayr42d(i,j) @@ -1475,8 +1487,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface latent heat flux, multiplied by -1 because ! wrf model flux has reversed sign vonvention using gfsio - if(trim(fieldname) == 'lhtfl_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) + if(trim(fieldname)=='lhtfl_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) do j=jsta,jend do i=ista, iend sfclhx(i,j) = arrayr42d(i,j) @@ -1486,8 +1498,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface latent heat flux - if(trim(fieldname) == 'lhtfl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) + if(trim(fieldname)=='lhtfl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) do j=jsta,jend do i=ista, iend qwbs(i,j) = arrayr42d(i,j) @@ -1497,30 +1509,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged ground heat flux - if(trim(fieldname) == 'gflux_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) + if(trim(fieldname)=='gflux_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend subshx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) subshx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval enddo enddo endif ! inst ground heat flux - if(trim(fieldname) == 'gflux') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) + if(trim(fieldname)=='gflux') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend grnflx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) grnflx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval enddo enddo endif ! time averaged zonal momentum flux - if(trim(fieldname) == 'uflx_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) + if(trim(fieldname)=='uflx_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) do j=jsta,jend do i=ista, iend sfcux(i,j) = arrayr42d(i,j) @@ -1529,8 +1541,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional momentum flux - if(trim(fieldname) == 'vflx_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) + if(trim(fieldname)=='vflx_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) do j=jsta,jend do i=ista, iend sfcvx(i,j) = arrayr42d(i,j) @@ -1539,8 +1551,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged zonal gravity wave stress - if(trim(fieldname) == 'u-gwd_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) + if(trim(fieldname)=='u-gwd_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) do j=jsta,jend do i=ista, iend gtaux(i,j) = arrayr42d(i,j) @@ -1549,8 +1561,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional gravity wave stress - if(trim(fieldname) == 'v-gwd_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) + if(trim(fieldname)=='v-gwd_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) do j=jsta,jend do i=ista, iend gtauy(i,j) = arrayr42d(i,j) @@ -1559,30 +1571,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged accumulated potential evaporation - if(trim(fieldname) == 'pevpr_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) + if(trim(fieldname)=='pevpr_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgpotevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgpotevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval enddo enddo endif ! inst potential evaporation - if(trim(fieldname) == 'pevpr') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) + if(trim(fieldname)=='pevpr') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend potevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) potevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval enddo enddo endif ! 10 m u - if(trim(fieldname) == 'ugrd10m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) + if(trim(fieldname)=='ugrd10m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) do j=jsta,jend do i=ista, iend u10(i,j) = arrayr42d(i,j) @@ -1592,8 +1604,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! 10 m v - if(trim(fieldname) == 'vgrd10m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) + if(trim(fieldname)=='vgrd10m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) do j=jsta,jend do i=ista, iend v10(i,j) = arrayr42d(i,j) @@ -1603,8 +1615,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation type - if(trim(fieldname) == 'vtype') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) + if(trim(fieldname)=='vtype') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1617,8 +1629,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil type - if(trim(fieldname) == 'sotyp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) + if(trim(fieldname)=='sotyp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1631,8 +1643,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud top pressure - if(trim(fieldname) == 'prescnvclt') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) + if(trim(fieldname)=='prescnvclt') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) do j=jsta,jend do i=ista, iend ptop(i,j) = arrayr42d(i,j) @@ -1642,8 +1654,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud bottom pressure - if(trim(fieldname) == 'prescnvclb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) + if(trim(fieldname)=='prescnvclb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) do j=jsta,jend do i=ista, iend pbot(i,j) = arrayr42d(i,j) @@ -1653,8 +1665,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top pressure - if(trim(fieldname) == 'pres_avelct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) + if(trim(fieldname)=='pres_avelct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) do j=jsta,jend do i=ista, iend ptopl(i,j) = arrayr42d(i,j) @@ -1663,8 +1675,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud bottom pressure - if(trim(fieldname) == 'pres_avelcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) + if(trim(fieldname)=='pres_avelcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) do j=jsta,jend do i=ista, iend pbotl(i,j) = arrayr42d(i,j) @@ -1673,8 +1685,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top temperature - if(trim(fieldname) == 'tmp_avelct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) + if(trim(fieldname)=='tmp_avelct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) do j=jsta,jend do i=ista, iend ttopl(i,j) = arrayr42d(i,j) @@ -1683,8 +1695,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top pressure - if(trim(fieldname) == 'pres_avemct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) + if(trim(fieldname)=='pres_avemct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) do j=jsta,jend do i=ista, iend ptopm(i,j) = arrayr42d(i,j) @@ -1693,8 +1705,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud bottom pressure - if(trim(fieldname) == 'pres_avemcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) + if(trim(fieldname)=='pres_avemcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) do j=jsta,jend do i=ista, iend pbotm(i,j) = arrayr42d(i,j) @@ -1703,8 +1715,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top temperature - if(trim(fieldname) == 'tmp_avemct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) + if(trim(fieldname)=='tmp_avemct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) do j=jsta,jend do i=ista, iend ttopm(i,j) = arrayr42d(i,j) @@ -1713,8 +1725,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top pressure - if(trim(fieldname) == 'pres_avehct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) + if(trim(fieldname)=='pres_avehct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) do j=jsta,jend do i=ista, iend ptoph(i,j) = arrayr42d(i,j) @@ -1723,8 +1735,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud bottom pressure - if(trim(fieldname) == 'pres_avehcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) + if(trim(fieldname)=='pres_avehcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) do j=jsta,jend do i=ista, iend pboth(i,j) = arrayr42d(i,j) @@ -1733,8 +1745,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top temperature - if(trim(fieldname) == 'tmp_avehct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) + if(trim(fieldname)=='tmp_avehct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) do j=jsta,jend do i=ista, iend ttoph(i,j) = arrayr42d(i,j) @@ -1743,8 +1755,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged boundary layer cloud cover - if(trim(fieldname) == 'tcdc_avebndcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) + if(trim(fieldname)=='tcdc_avebndcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) do j=jsta,jend do i=ista, iend pblcfr(i,j) = arrayr42d(i,j) @@ -1754,8 +1766,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! cloud work function - if(trim(fieldname) == 'cwork_aveclm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) + if(trim(fieldname)=='cwork_aveclm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) do j=jsta,jend do i=ista, iend cldwork(i,j) = arrayr42d(i,j) @@ -1764,8 +1776,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! water runoff - if(trim(fieldname) == 'watr_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) + if(trim(fieldname)=='watr_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) do j=jsta,jend do i=ista, iend runoff(i,j) = arrayr42d(i,j) @@ -1775,8 +1787,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max temperature - if(trim(fieldname) == 'tmax_max2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) + if(trim(fieldname)=='tmax_max2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxtshltr(i,j) = arrayr42d(i,j) @@ -1785,8 +1797,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname) == 'tmin_min2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) + if(trim(fieldname)=='tmin_min2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) do j=jsta,jend do i=ista, iend mintshltr(i,j) = arrayr42d(i,j) @@ -1795,8 +1807,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ice thickness - if(trim(fieldname) == 'icetk') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) + if(trim(fieldname)=='icetk') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) do j=jsta,jend do i=ista, iend dzice(i,j) = arrayr42d(i,j) @@ -1805,8 +1817,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! wilting point - if(trim(fieldname) == 'wilt') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) + if(trim(fieldname)=='wilt') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) do j=jsta,jend do i=ista, iend smcwlt(i,j) = arrayr42d(i,j) @@ -1816,8 +1828,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sunshine duration - if(trim(fieldname) == 'sunsd_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) + if(trim(fieldname)=='sunsd_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) do j=jsta,jend do i=ista, iend suntime(i,j) = arrayr42d(i,j) @@ -1826,8 +1838,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! field capacity - if(trim(fieldname) == 'fldcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) + if(trim(fieldname)=='fldcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) do j=jsta,jend do i=ista, iend fieldcapa(i,j) = arrayr42d(i,j) @@ -1837,8 +1849,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible beam downward solar flux - if(trim(fieldname) == 'vbdsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) + if(trim(fieldname)=='vbdsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend avisbeamswin(i,j) = arrayr42d(i,j) @@ -1847,8 +1859,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible diffuse downward solar flux - if(trim(fieldname) == 'vddsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) + if(trim(fieldname)=='vddsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend avisdiffswin(i,j) = arrayr42d(i,j) @@ -1857,8 +1869,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR beam downward solar flux - if(trim(fieldname) == 'nbdsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) + if(trim(fieldname)=='nbdsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend airbeamswin(i,j) = arrayr42d(i,j) @@ -1867,8 +1879,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR diffuse downward solar flux - if(trim(fieldname) == 'nddsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) + if(trim(fieldname)=='nddsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend airdiffswin(i,j) = arrayr42d(i,j) @@ -1877,8 +1889,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing LW - if(trim(fieldname) == 'csulf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) + if(trim(fieldname)=='csulf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) do j=jsta,jend do i=ista, iend alwoutc(i,j) = arrayr42d(i,j) @@ -1887,8 +1899,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing LW - if(trim(fieldname) == 'csulftoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) + if(trim(fieldname)=='csulftoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) do j=jsta,jend do i=ista, iend alwtoac(i,j) = arrayr42d(i,j) @@ -1897,8 +1909,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing SW - if(trim(fieldname) == 'csusf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) + if(trim(fieldname)=='csusf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) do j=jsta,jend do i=ista, iend aswoutc(i,j) = arrayr42d(i,j) @@ -1907,8 +1919,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing SW - if(trim(fieldname) == 'csusftoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) + if(trim(fieldname)=='csusftoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) do j=jsta,jend do i=ista, iend aswtoac(i,j) = arrayr42d(i,j) @@ -1917,8 +1929,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming LW - if(trim(fieldname) == 'csdlf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) + if(trim(fieldname)=='csdlf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) do j=jsta,jend do i=ista, iend alwinc(i,j) = arrayr42d(i,j) @@ -1927,8 +1939,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming SW - if(trim(fieldname) == 'csdsf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) + if(trim(fieldname)=='csdsf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) do j=jsta,jend do i=ista, iend aswinc(i,j) = arrayr42d(i,j) @@ -1937,8 +1949,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max specific humidity - if(trim(fieldname) == 'spfhmax_max2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) + if(trim(fieldname)=='spfhmax_max2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxqshltr(i,j) = arrayr42d(i,j) @@ -1947,8 +1959,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname) == 'spfhmin_min2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) + if(trim(fieldname)=='spfhmin_min2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) do j=jsta,jend do i=ista, iend minqshltr(i,j) = arrayr42d(i,j) @@ -1957,8 +1969,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! storm runoffs - if(trim(fieldname) == 'ssrun_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) + if(trim(fieldname)=='ssrun_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) do j=jsta,jend do i=ista, iend ssroff(i,j) = arrayr42d(i,j) @@ -1968,8 +1980,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! direct soil evaporation - if(trim(fieldname) == 'evbs_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) + if(trim(fieldname)=='evbs_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgedir(i,j) = arrayr42d(i,j) @@ -1979,8 +1991,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! canopy water evap - if(trim(fieldname) == 'evcw_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) + if(trim(fieldname)=='evcw_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgecan(i,j) = arrayr42d(i,j) @@ -1990,8 +2002,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! plant transpiration - if(trim(fieldname) == 'trans_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) + if(trim(fieldname)=='trans_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgetrans(i,j) = arrayr42d(i,j) @@ -2001,19 +2013,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow sublimation - if(trim(fieldname) == 'sbsno_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) + if(trim(fieldname)=='sbsno_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgesnow(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgesnow(i,j) = spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval enddo enddo endif ! total soil moisture - if(trim(fieldname) == 'soilm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) + if(trim(fieldname)=='soilm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) do j=jsta,jend do i=ista, iend smstot(i,j) = arrayr42d(i,j) @@ -2023,8 +2035,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow phase change heat flux - if(trim(fieldname) == 'snohf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) + if(trim(fieldname)=='snohf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) do j=jsta,jend do i=ista, iend snopcx(i,j) = arrayr42d(i,j) @@ -2034,17 +2046,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! else if (fieldDimCount > gridDimCount) then - else if (fieldDimCount == 3) then + else if (fieldDimCount ==3) then if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr43d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr83d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out allocate(arrayr43d(ista:iend,jsta:jend,kstart:kend)) arrayr43d = 0. do k=kstart,kend -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) do j=jsta,jend do i=ista,iend arrayr43d(i,j,k) = arrayr83d(i,j,k) @@ -2054,8 +2068,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level T - if(trim(fieldname) == 'tmp') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) + if(trim(fieldname)=='tmp') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend @@ -2065,7 +2079,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo !! sig4 -!$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) + !$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) do j=jsta,jend do i=ista, iend tlmh = t(i,j,lm) * t(i,j,lm) @@ -2075,237 +2089,172 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level spfh - if(trim(fieldname) == 'spfh') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) + if(trim(fieldname)=='spfh') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q(i,j,l) = arrayr43d(i,j,l) + q(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level u wind - if(trim(fieldname) == 'ugrd') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) + if(trim(fieldname)=='ugrd') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - uh(i,j,l) = arrayr43d(i,j,l) + uh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level v wind - if(trim(fieldname) == 'vgrd') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) + if(trim(fieldname)=='vgrd') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - vh(i,j,l) = arrayr43d(i,j,l) + vh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level pressure thinkness - if(trim(fieldname) == 'dpres') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) + if(trim(fieldname)=='dpres') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - dpres(i,j,l) = arrayr43d(i,j,l) + dpres(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level gh thinkness, model output negative delz - if(trim(fieldname) == 'delz') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) + if(trim(fieldname)=='delz') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - zint(i,j,l) = -arrayr43d(i,j,l) + zint(i,j,l)=-1.*arrayr43d(i,j,l) enddo enddo enddo endif ! model level w - if(trim(fieldname) == 'dzdt') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) + if(trim(fieldname)=='dzdt') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - wh(i,j,l) = arrayr43d(i,j,l) + wh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ozone mixing ratio - if(trim(fieldname) == 'o3mr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) + if(trim(fieldname)=='o3mr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - o3(i,j,l) = arrayr43d(i,j,l) + o3(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif -! for GFDL or MG3 MP -! ------------------ - if (imp_physics == 10 .or. imp_physics == 11) then +! for GFDL MP + if (imp_physics == 11) then ! model level cloud water mixing ratio - if(trim(fieldname) == 'clwmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) + if(trim(fieldname)=='clwmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqw(i,j,l) = arrayr43d(i,j,l) + qqw(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ice mixing ratio - if(trim(fieldname) == 'icmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) + if(trim(fieldname)=='icmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqi(i,j,l) = arrayr43d(i,j,l) + qqi(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname) == 'rwmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) + if(trim(fieldname)=='rwmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqr(i,j,l) = arrayr43d(i,j,l) + qqr(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level snow mixing ratio - if(trim(fieldname) == 'snmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) + if(trim(fieldname)=='snmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqs(i,j,l) = arrayr43d(i,j,l) + qqs(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname) == 'grle') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqg(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - endif !gfdlmp or MG3 mp -! for MG3 MP -! ---------- - if (imp_physics == 10) then - ! model level cloud water mixing ratio number concentration - if(trim(fieldname) == 'clwnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnw,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqnw(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level ice mixing ratio number concentration - if(trim(fieldname) == 'icenc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqni,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqni(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level rain water mixing ratio number concentration - if(trim(fieldname) == 'rwnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnr,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqnr(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level snow mixing ratio number concentration - if(trim(fieldname) == 'snnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqns,arrayr43d) + if(trim(fieldname)=='grle') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqns(i,j,l) = arrayr43d(i,j,l) + qqg(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif - - ! model level rain water mixing ratio number concentration - if(trim(fieldname) == 'grlenc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqng,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqng(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - endif ! for MG3 MP +!gfdlmp + endif ! model level cloud amount - if(trim(fieldname) == 'cld_amt') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) + if(trim(fieldname)=='cld_amt') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - cfr(i,j,l) = arrayr43d(i,j,l) + cfr(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ref3d - if(trim(fieldname) == 'ref3D') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) + if(trim(fieldname)=='ref3D') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - ref_10cm(i,j,l) = arrayr43d(i,j,l) + ref_10cm(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo @@ -2313,12 +2262,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level ref3d - if(trim(fieldname) == 'tke') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) + if(trim(fieldname)=='tke') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q2(i,j,l) = arrayr43d(i,j,l) + q2(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo @@ -2326,7 +2275,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !3d fields endif - enddo ! end loop ncount_field +! end loop ncount_field + enddo if ( index(trim(wrt_int_state%wrtFB_names(ibdl)),trim(filename_base(1))) > 0) & setvar_atmfile = .true. @@ -2352,33 +2302,46 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,omga,wh,dpres,zint) do j=jsta,jend do i=1,im - omga(i,j,l) = - wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) + omga(i,j,l) = (-1.) * wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) zint(i,j,l) = zint(i,j,l) + zint(i,j,l+1) enddo enddo enddo ! compute pint from top down -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint,pd,spval) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint) do j=jsta,jend do i=1,im pint(i,j,1) = ak5(1) - pd(i,j) = spval - enddo - enddo + end do + end do do l=2,lp1 - ll = l - 1 -!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,pint,dpres,pmid) +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pint,dpres) do j=jsta,jend do i=1,im - pint(i,j,l) = pint(i,j,ll) + dpres(i,j,ll) + pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) + enddo + enddo + end do + !compute pmid from averaged two layer pint - pmid(i,j,ll) = 0.5*(pint(i,j,ll)+pint(i,j,l)) + do l=lm,1,-1 +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pmid,pint) + do j=jsta,jend + do i=1,im + pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) enddo enddo enddo +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,spval,pt,pd,pint) + do j=jsta,jend + do i=1,im + pd(i,j) = spval + pint(i,j,1) = pt + end do + end do ! print *,'in setvar, pt=',pt,'ak5(lp1)=', ak5(lp1),'ak5(1)=',ak5(1) ! compute alpint @@ -2386,23 +2349,22 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,alpint,pint) do j=jsta,jend do i=1,im - alpint(i,j,l) = log(pint(i,j,l)) - enddo - enddo - enddo + alpint(i,j,l)=log(pint(i,j,l)) + end do + end do + end do ! compute zmid do l=lm,1,-1 - ll = l + 1 -!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,zmid,zint,pmid,alpint) +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,zmid,zint,pmid,alpint) do j=jsta,jend do i=1,im - zmid(i,j,l) = zint(i,j,ll) + (zint(i,j,l)-zint(i,j,ll)) & - * (log(pmid(i,j,l))-alpint(i,j,ll)) & - / (alpint(i,j,l)-alpint(i,j,ll)) - enddo - enddo - enddo + zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & + (log(pmid(i,j,l))-alpint(i,j,l+1))/ & + (alpint(i,j,l)-alpint(i,j,l+1)) + end do + end do + end do ! print *,'in post_gfs,zmid=',maxval(zmid(1:im,jsta:jend,1)), & ! minval(zmid(1:im,jsta:jend,1)),maxloc(zmid(1:im,jsta:jend,1)), & ! 'zint=',maxval(zint(1:im,jsta:jend,2)),minval(zint(1:im,jsta:jend,1)), & @@ -2428,13 +2390,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo enddo -! compute cwm for gfdlmp or MG3 - if( imp_physics == 10 .or. imp_physics == 11) then +! compute cwm for gfdlmp + if( imp_physics == 11 ) then do l=1,lm !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,ista,iend,cwm,qqg,qqs,qqr,qqi,qqw) do j=jsta,jend do i=ista,iend - cwm(i,j,l) = qqg(i,j,l) + qqs(i,j,l) + qqr(i,j,l) + qqi(i,j,l) + qqw(i,j,l) + cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) enddo enddo enddo @@ -2444,8 +2406,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,lm,pshltr,pint,tshltr) do j=jsta,jend do i=ista, iend - pshltr(I,J) = pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j) = tshltr(i,j)*(p1000/pshltr(I,J))**CAPA + pshltr(I,J)=pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) + tshltr(i,j)= tshltr(i,j)*(p1000/pshltr(I,J))**CAPA enddo enddo @@ -2456,13 +2418,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if(ptop(i,j) < spval)then do l=1,lm if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l + htop(i,j)=l exit - endif - enddo - endif - enddo - enddo + end if + end do + end if + end do + end do ! hbot do j=jsta,jend From 69f4033477942ec23054eb8c6583ef7e23ad2ddf Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 28 Jul 2020 14:54:08 +0000 Subject: [PATCH 68/91] syncing submodule ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index c2c4492d1..cfb269ced 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit c2c4492d1c137a54eae76a6aa3c83515a1e36f35 +Subproject commit cfb269cedfc42a9016c18331cd9cf3bdba7f4a9f From 6fb21f113d737c881ac078deae7201dfadcfa961 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 3 Aug 2020 13:34:48 +0000 Subject: [PATCH 69/91] fixing issues related to z0 and restart reproducibility --- atmos_model.F90 | 2 + ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 28 +++-- gfsphysics/physics/gcycle.F90 | 16 ++- io/FV3GFS_io.F90 | 117 ++++++++++---------- 5 files changed, 91 insertions(+), 74 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 1300f9251..7c6962fe8 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1661,6 +1661,7 @@ subroutine assign_importdata(rc) real(kind=IPD_kind_phys), dimension(:,:), pointer :: datar8 real(kind=IPD_kind_phys) :: tem, ofrac logical found, isFieldCreated, lcpl_fice + real (kind=IPD_kind_phys), parameter :: z0ice=0.011 ! !------------------------------------------------------------------------------ ! @@ -2006,6 +2007,7 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) & / max(0.01_IPD_kind_phys, IPD_Data(nb)%Sfcprop%fice(ix)) ! / max(0.01_IPD_kind_phys, IPD_Data(nb)%Coupling%ficein_cpl(ix)) + IPD_Data(nb)%Sfcprop%zorli(ix) = z0ice else ! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Sfcprop%tsfco(ix) diff --git a/ccpp/physics b/ccpp/physics index cfb269ced..e53009676 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit cfb269cedfc42a9016c18331cd9cf3bdba7f4a9f +Subproject commit e530096764773b67fa30c7f3b11285c81bb5374d diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index ff12d1953..715f91ddd 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -649,6 +649,7 @@ subroutine GFS_physics_driver & hflxq, evapq, hffac, hefac real (kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 real (kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 + real (kind=kind_phys), parameter :: z0ice=0.011 ! !=============================================================================== @@ -1224,19 +1225,20 @@ subroutine GFS_physics_driver & gabsbdlw3(i,k) = zero enddo enddo + zorl3(:,2) = z0ice - if (.not. Model%cplflx .or. .not. Model%frac_grid) then - if (Model%cplwav2atm) then - do i=1,im - Sfcprop%zorll(i) = Sfcprop%zorl(i) - enddo - else - do i=1,im - Sfcprop%zorll(i) = Sfcprop%zorl(i) - Sfcprop%zorlo(i) = Sfcprop%zorl(i) - enddo - endif - endif +! if (.not. Model%cplflx .or. .not. Model%frac_grid) then +! if (Model%cplwav2atm) then +! do i=1,im +! Sfcprop%zorll(i) = Sfcprop%zorl(i) +! enddo +! else +! do i=1,im +! Sfcprop%zorll(i) = Sfcprop%zorl(i) +! Sfcprop%zorlo(i) = Sfcprop%zorl(i) +! enddo +! endif +! endif ! if (lprnt) write(0,*)' dry=',dry(ipr),' wet=',wet(ipr),' icy=',icy(ipr) ,& ! ' tsfco=',Sfcprop%tsfco(ipr) do i=1,im @@ -2236,11 +2238,13 @@ subroutine GFS_physics_driver & stress(i) = txi *stress3(i,2) + txo * stress3(i,3) qss(i) = txi * qss3(i,2) + txo * qss3(i,3) ep1d(i) = txi * ep1d3(i,2) + txo * ep1d3(i,3) + Sfcprop%zorl(i) = txi*zorl3(i,2) + txo*zorl3(i,3) endif elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) Sfcprop%hice(i) = zice(i) Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen + Sfcprop%zorl(i) = fice(i)*zorl3(i,2) + (one-fice(i))*zorl3(i,3) else ! this would be over open ocean or land (no ice fraction) Sfcprop%hice(i) = zero Sfcprop%fice(i) = zero diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index 8e799fb12..64d234091 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -102,7 +102,12 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) TSFFCS(len) = Sfcprop(nb)%tsfc (ix) endif SNOFCS (len) = Sfcprop(nb)%weasd (ix) - ZORFCS (len) = Sfcprop(nb)%zorl (ix) + ZORFCS (len) = Sfcprop(nb)%zorll (ix) + if (SLIFCS(len) > 1.9_kind_phys .and. .not. Model%frac_grid) then + ZORFCS (len) = Sfcprop(nb)%zorli (ix) + elseif (SLIFCS(len) < 0.1_kind_phys .and. .not. Model%frac_grid) then + ZORFCS (len) = Sfcprop(nb)%zorlo (ix) + endif TG3FCS (len) = Sfcprop(nb)%tg3 (ix) CNPFCS (len) = Sfcprop(nb)%canopy (ix) ! F10MFCS (len) = Sfcprop(nb)%f10m (ix) @@ -210,7 +215,12 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%tsfco(ix) = TSFFCS (len) endif Sfcprop(nb)%weasd (ix) = SNOFCS (len) - Sfcprop(nb)%zorl (ix) = ZORFCS (len) + Sfcprop(nb)%zorll (ix) = ZORFCS (len) + if (SLIFCS(len) > 1.9_kind_phys .and. .not. Model%frac_grid) then + Sfcprop(nb)%zorli(ix) = ZORFCS (len) + elseif (SLIFCS(len) < 0.1_kind_phys .and. .not. Model%frac_grid) then + Sfcprop(nb)%zorlo(ix) = ZORFCS (len) + endif Sfcprop(nb)%tg3 (ix) = TG3FCS (len) Sfcprop(nb)%canopy (ix) = CNPFCS (len) ! Sfcprop(nb)%f10m (ix) = F10MFCS (len) @@ -243,7 +253,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%slc (ix,ls) = SLCFC1 (ll) if (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (ll) enddo - ENDDO !-----END BLOCK SIZE LOOP------------------------------ + ENDDO !-----END BLOCK SIZE LOOP-------------------------- ENDDO !-----END BLOCK LOOP------------------------------- ! check diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 95b372659..e0898c3f6 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -643,13 +643,11 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo - if (Model%frac_grid) then ! needs more variables +! if (Model%frac_grid) then ! needs more variables nvar_s2m = 35 - elseif (Model%cplflx) then ! needs more variables - nvar_s2m = 34 - else - nvar_s2m = 32 - endif +! else +! nvar_s2m = 32 +! endif if (Model%cplwav) then nvar_s2m = nvar_s2m + 1 endif @@ -803,13 +801,11 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) sfc_name2(31) = 'snoalb' !--- variables below here are optional sfc_name2(32) = 'sncovr' - if(Model%cplflx .or. Model%frac_grid) then +! if(Model%frac_grid) then sfc_name2(33) = 'tsfcl' !temp on land portion of a cell sfc_name2(34) = 'zorll' !zorl on land portion of a cell - endif - if(Model%frac_grid) then sfc_name2(35) = 'zorli' !zorl on land portion of a cell - endif +! endif if(Model%cplwav) then sfc_name2(nvar_s2m) = 'zorlw' !zorl on land portion of a cell endif @@ -1047,15 +1043,19 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%slope(ix) = sfc_var2(i,j,30) !--- slope Sfcprop(nb)%snoalb(ix) = sfc_var2(i,j,31) !--- snoalb Sfcprop(nb)%sncovr(ix) = sfc_var2(i,j,32) !--- sncovr - if(Model%cplflx .or. Model%frac_grid) then +! if(Model%frac_grid) then Sfcprop(nb)%tsfcl(ix) = sfc_var2(i,j,33) !--- sfcl (temp on land portion of a cell) Sfcprop(nb)%zorll(ix) = sfc_var2(i,j,34) !--- zorll (zorl on land portion of a cell) - endif - if(Model%frac_grid) then Sfcprop(nb)%zorli(ix) = sfc_var2(i,j,35) !--- zorll (zorl on ice portion of a cell) - endif +! else +! Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) +! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) +! endif if(Model%cplwav) then Sfcprop(nb)%zorlw(ix) = sfc_var2(i,j,nvar_s2m) !--- (zorw from wave model) + else + Sfcprop(nb)%zorlw(ix) = Sfcprop(nb)%zorlo(ix) endif if(Model%frac_grid) then ! obtain slmsk from landfrac @@ -1073,7 +1073,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) else Sfcprop(nb)%landfrac(ix) = Sfcprop(nb)%slmsk(ix) endif - end if + endif if (Sfcprop(nb)%lakefrac(ix) > zero) then Sfcprop(nb)%oceanfrac(ix) = zero ! lake & ocean don't coexist in a cell @@ -1296,7 +1296,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo endif - if (Model%cplflx .or. Model%frac_grid) then +! if (Model%frac_grid) then if (sfc_var2(i,j,33) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tsfcl') @@ -1317,8 +1317,6 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo endif - endif - if (Model%frac_grid) then if (sfc_var2(i,j,35) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorli') @@ -1329,8 +1327,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo endif - endif - if (Model%frac_grid) then + if (sfc_var2(i,j,nvar_s2m) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorli') !$omp parallel do default(shared) private(nb, ix) @@ -1340,20 +1337,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo endif - endif - -!#ifdef CCPP - if (nint(sfc_var3ice(1,1,1)) == -9999) then - if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tiice') - do nb = 1, Atm_block%nblks - do ix = 1, Atm_block%blksz(nb) - Sfcprop(nb)%tiice(ix,1) = Sfcprop(nb)%stc(ix,1) !--- initialize internal ice temp from soil temp at layer 1 - Sfcprop(nb)%tiice(ix,2) = Sfcprop(nb)%stc(ix,2) !--- initialize internal ice temp from soil temp at layer 2 - enddo - enddo - endif -!#endif !#endif if(Model%frac_grid) then ! 3-way composite @@ -1377,15 +1361,38 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) !--- specify tsfcl/zorll/zorli from existing variable tsfco/zorlo - Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) - Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) - Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) - Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) - Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) +! Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) +! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) + if (Sfcprop(nb)%slmsk(ix) == 1) then + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + else + tem = one - Sfcprop(nb)%fice(ix) + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%zorlo(ix) * tem + + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%tsfco(ix) * tem + endif enddo enddo endif ! if (Model%frac_grid) +!#ifdef CCPP + if (nint(sfc_var3ice(1,1,1)) == -9999) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tiice') + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + Sfcprop(nb)%tiice(ix,1) = Sfcprop(nb)%stc(ix,1) !--- initialize internal ice temp from soil temp at layer 1 + Sfcprop(nb)%tiice(ix,2) = Sfcprop(nb)%stc(ix,2) !--- initialize internal ice temp from soil temp at layer 2 + enddo + enddo + endif +!#endif + if (Model%lsm == Model%lsm_noahmp) then if (nint(sfc_var2(1,1,nvar_s2m+19)) == -66666) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver:: - Cold start Noah MP ') @@ -1687,13 +1694,11 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p2 => NULL() real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p3 => NULL() - if (Model%frac_grid) then ! needs more variables +! if (Model%frac_grid) then ! needs more variables nvar2m = 35 - elseif (Model%cplflx) then ! needs more variables - nvar2m = 34 - else - nvar2m = 32 - endif +! else +! nvar2m = 32 +! endif if (Model%cplwav) nvar2m = nvar2m + 1 nvar2o = 18 #ifdef CCPP @@ -1808,13 +1813,11 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name2(31) = 'snoalb' !--- variables below here are optional sfc_name2(32) = 'sncovr' - if (Model%cplflx .or. Model%frac_grid) then +! if (Model%frac_grid) then sfc_name2(33) = 'tsfcl' !temp on land portion of a cell sfc_name2(34) = 'zorll' !zorl on land portion of a cell - endif - if (Model%frac_grid) then sfc_name2(35) = 'zorli' !zorl on land portion of a cell - endif +! endif if (Model%cplwav) then sfc_name2(nvar2m) = 'zorlw' !zorl on land portion of a cell endif @@ -1995,13 +1998,13 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta i = Atm_block%index(nb)%ii(ix) - isc + 1 j = Atm_block%index(nb)%jj(ix) - jsc + 1 sfc_var2(i,j,1) = Sfcprop(nb)%slmsk(ix) !--- slmsk - if (Model%frac_grid) then +! if (Model%frac_grid) then sfc_var2(i,j,2) = Sfcprop(nb)%tsfco(ix) !--- tsfc (tsea in sfc file) sfc_var2(i,j,5) = Sfcprop(nb)%zorlo(ix) !--- zorlo - else - sfc_var2(i,j,2) = Sfcprop(nb)%tsfc(ix) !--- tsfc (tsea in sfc file) - sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl - endif +! else +! sfc_var2(i,j,2) = Sfcprop(nb)%tsfc(ix) !--- tsfc (tsea in sfc file) +! sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl +! endif sfc_var2(i,j,3) = Sfcprop(nb)%weasd(ix) !--- weasd (sheleg in sfc file) sfc_var2(i,j,4) = Sfcprop(nb)%tg3(ix) !--- tg3 ! sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl @@ -2032,15 +2035,13 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_var2(i,j,30) = Sfcprop(nb)%slope(ix) !--- slope sfc_var2(i,j,31) = Sfcprop(nb)%snoalb(ix)!--- snoalb sfc_var2(i,j,32) = Sfcprop(nb)%sncovr(ix)!--- sncovr - if (Model%cplflx .or. Model%frac_grid) then +! if (Model%frac_grid) then sfc_var2(i,j,33) = Sfcprop(nb)%tsfcl(ix) !--- tsfcl (temp on land) sfc_var2(i,j,34) = Sfcprop(nb)%zorll(ix) !--- zorll (zorl on land) - endif - if (Model%frac_grid) then sfc_var2(i,j,35) = Sfcprop(nb)%zorli(ix) !--- zorli (zorl on ice) - endif +! endif if (Model%cplwav) then - sfc_var2(i,j,nvar2m) = Sfcprop(nb)%zorli(ix) !--- zorlw (zorl from wav) + sfc_var2(i,j,nvar2m) = Sfcprop(nb)%zorlw(ix) !--- zorlw (zorl from wav) endif !--- NSSTM variables if (Model%nstf_name(1) > 0) then From 51cce857767ef485e701209b52d067b76b256821 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 3 Aug 2020 13:38:47 +0000 Subject: [PATCH 70/91] after submodule sync --- .gitmodules | 2 +- ccpp/physics | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 491629970..c3ceea468 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,4 +9,4 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics - branch = SM_Jul212020 + branch = SM_Jul302020 diff --git a/ccpp/physics b/ccpp/physics index e53009676..4b11e8491 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit e530096764773b67fa30c7f3b11285c81bb5374d +Subproject commit 4b11e849183fa7635c0db6fd0631159159ec126c From 7cb03c42169fab3b974770f3dc093d18415a8912 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 4 Aug 2020 14:04:49 +0000 Subject: [PATCH 71/91] changing post_gfs back to the version that works with double moment microphysics - i.e. MGx schemes --- io/post_gfs.F90 | 922 +++++++++++++++++++++++++----------------------- 1 file changed, 480 insertions(+), 442 deletions(-) diff --git a/io/post_gfs.F90 b/io/post_gfs.F90 index 76dd0251c..248ce6d06 100644 --- a/io/post_gfs.F90 +++ b/io/post_gfs.F90 @@ -112,19 +112,20 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & !----------------------------------------------------------------------- ! ! if(mype==0) print *,'in post_run,be post_alctvars, dim=',wrt_int_state%im, & -! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & -! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & +! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & +! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & ! 'jstagrp=',jstagrp,'jendgrp=',jendgrp - call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & - wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & - mpicomp,jts,jte,jstagrp,jendgrp) + + call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & + wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & + mpicomp,jts,jte,jstagrp,jendgrp) ! !----------------------------------------------------------------------- !*** read namelist for pv,th,po !----------------------------------------------------------------------- ! - log_postalct = .true. - first_grbtbl = .true. + log_postalct = .true. + first_grbtbl = .true. read_postcntrl = .true. ! ENDIF @@ -137,16 +138,16 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & ifmin = mynfmin if (ifhr == 0 ) ifmin = 0 if(mype==0) print *,'bf set_postvars,ifmin=',ifmin,'ifhr=',ifhr - setvar_atmfile=.false. - setvar_sfcfile=.false. + setvar_atmfile = .false. + setvar_sfcfile = .false. call set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & - setvar_sfcfile) + setvar_sfcfile) ! print *,'af set_postvars,setvar_atmfile=',setvar_atmfile, & ! 'setvar_sfcfile=',setvar_sfcfile ! if (setvar_atmfile.and.setvar_sfcfile) then -! 20190807 no need to call microinit for GFDLMP +! 20190807 need to call microinit only for Ferrier microphysics ! call MICROINIT ! if(grib=="grib2" .and. read_postcntrl) then @@ -239,66 +240,62 @@ subroutine post_getattr_gfs(wrt_int_state, fldbundle) ! look at the field bundle attributes call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, Count=attcount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__,file=__FILE__))return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return ! aklen=0. do i=1, attCount - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & - typekind=typekind, itemCount=n, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__,file=__FILE__))return ! bail out + call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & + attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & + typekind=typekind, itemCount=n, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return if (typekind==ESMF_TYPEKIND_I4 ) then - if(n==1) then + if(n == 1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, rc=rc) - if (trim(attName) == 'ncnsto') wrt_int_state%ntrac=varival - if (trim(attName) == 'ncld') wrt_int_state%ncld=varival - if (trim(attName) == 'nsoil') wrt_int_state%nsoil=varival - if (trim(attName) == 'fhzero') wrt_int_state%fhzero=varival - if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics=varival + name=trim(attName), value=varival, rc=rc) + if (trim(attName) == 'ncnsto') wrt_int_state%ntrac = varival + if (trim(attName) == 'ncld') wrt_int_state%ncld = varival + if (trim(attName) == 'nsoil') wrt_int_state%nsoil = varival + if (trim(attName) == 'fhzero') wrt_int_state%fhzero = varival + if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics = varival endif - else if (typekind==ESMF_TYPEKIND_R4) then - if(n==1) then + else if (typekind == ESMF_TYPEKIND_R4) then + if(n == 1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr4val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + name=trim(attName), value=varr4val, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr4val endif - else if(n>1) then + else if(n > 1) then if(trim(attName) =="ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 - else if(trim(attName) =="bk") then + else if(trim(attName) == "bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) allocate(wrt_int_state%bk(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%bk, rc=rc) + name=trim(attName), valueList=wrt_int_state%bk, rc=rc) endif endif - else if (typekind==ESMF_TYPEKIND_R8) then - if(n==1) then + else if (typekind == ESMF_TYPEKIND_R8) then + if(n == 1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & name=trim(attName), value=varr8val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr8val endif - else if(n>1) then - if(trim(attName) =="ak") then + else if(n > 1) then + if(trim(attName) == "ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 else if(trim(attName) =="bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) @@ -332,7 +329,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use vrbls3d, only: t, q, uh, vh, wh, alpint, dpres, zint, zmid, o3, & qqr, qqs, cwm, qqi, qqw, qqg, omga, cfr, pmid, & q2, rlwtt, rswtt, tcucn, tcucns, train, el_pbl, & - pint, exch_h, ref_10cm + pint, exch_h, ref_10cm, & + qqnw, qqni, qqnr, qqns, qqng use vrbls2d, only: f, pd, sigt4, fis, pblh, ustar, z0, ths, qs, twbs,& qwbs, avgcprate, cprate, avgprec, prec, lspa, sno,& cldefi, th10, q10, tshltr, pshltr, tshltr, albase,& @@ -360,11 +358,11 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use soil, only: sldpth, sh2o, smc, stc use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice use ctlblk_mod, only: im, jm, lm, lp1, jsta, jend, jsta_2l, jend_2u, jsta_m,jend_m, & - lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & - tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & + lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & + tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & ardlw, ardsw, asrfc, avrain, avcnvc, iSF_SURFACE_PHYSICS,& - td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & - alsl, spl, ihrst + td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & + alsl, spl, ihrst use params_mod, only: erad, dtr, capa, p1000 use gridspec_mod,only: latstart, latlast, lonstart, lonlast, cenlon, cenlat use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, & @@ -389,12 +387,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! !----------------------------------------------------------------------- ! - integer i, ip1, j, l, k, n, iret, ibdl, rc, kstart, kend + integer i, ip1, j, l, ll, k, n, iret, ibdl, rc, kstart, kend integer ista,iend,fieldDimCount,gridDimCount,ncount_field integer jdate(8) logical foundland, foundice, found real(4) rinc(5) - real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp + real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp, dtq2001 real, dimension(:),allocatable :: ak5, bk5 real(4),dimension(:,:),pointer :: arrayr42d real(8),dimension(:,:),pointer :: arrayr82d @@ -473,7 +471,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & end do ! ! GFS does not output PD - pt = ak5(1) + pt = ak5(1) ! GFS may not have model derived radar ref. ! TKE @@ -484,7 +482,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & do j=jsta,jend do i=1,im ref_10cm(i,j,l) = SPVAL - q2(i,j,l) = SPVAL + q2(i,j,l) = SPVAL cfr(i,j,l) = SPVAL enddo enddo @@ -496,10 +494,10 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none),private(i,j),shared(jsta,jend,im,spval,qs,twbs,qwbs,ths) do j=jsta,jend do i=1,im - qs(i,j) = SPVAL + qs(i,j) = SPVAL twbs(i,j) = SPVAL qwbs(i,j) = SPVAL - ths(i,j) = SPVAL + ths(i,j) = SPVAL enddo enddo @@ -507,6 +505,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & dtq2 = wrt_int_state%dtp nphs = 2. dt = dtq2/nphs + dtq2001 = dtq2*0.001 ! ! GFS does not have convective cloud efficiency ! similated precip @@ -514,22 +513,16 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! 10 m humidity ! snow free albedo !$omp parallel do default(none), private(i,j), shared(jsta,jend,im,spval), & -!$omp& shared(cldefi,lspa,th10,q10,albase) +!$omp& shared(cldefi,lspa,th10,q10,albase,cprate) do j=jsta,jend do i=1,im cldefi(i,j) = SPVAL - lspa(i,j) = SPVAL - th10(i,j) = SPVAL - q10(i,j) = SPVAL + lspa(i,j) = SPVAL + th10(i,j) = SPVAL + q10(i,j) = SPVAL albase(i,j) = SPVAL - enddo - enddo -! GFS does not have convective precip -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,cprate) - do j=jsta,jend - do i=1,im - cprate(i,j) = 0. + cprate(i,j) = 0.0 ! GFS does not have convective precip ???? enddo enddo @@ -604,7 +597,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp& shared(rlwtt,rswtt,tcucn,tcucns,train) do j=jsta_2l,jend_2u do i=1,im - rlwtt(i,j,l) = spval + rlwtt(i,j,l) = spval rswtt(i,j,l) = spval tcucn(i,j,l) = spval tcucns(i,j,l) = spval @@ -720,19 +713,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find lans sea mask found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),fieldName='land',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! if(mype==0) print *,'ibdl=',ibdl,'land, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'land',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) - !$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) +!$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) do j=jsta, jend do i=ista, iend if (arrayr42d(i,j) /= spval) sm(i,j) = 1.- arrayr42d(i,j) @@ -744,19 +737,17 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find ice fraction found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! if(mype==0) print *,'ibdl=',ibdl,'ice, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) do j=jsta, jend do i=ista, iend sice(i,j) = arrayr42d(i,j) @@ -768,9 +759,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo get_lsmsk if (.not.foundland .or. .not.foundice) then - rc=999 - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + rc = 999 + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return endif if(mype==0) print *,'after find sm and sice,imp_physics=',imp_physics,'nbdl=',wrt_int_state%FBCount ! @@ -778,29 +768,27 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! ! get grid dimension count ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl,'idim=', & -! ista,iend,'jdim=',jsta,jend +! ista,iend,'jdim=',jsta,jend call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), grid=wrtGrid, & - fieldCount=ncount_field, name=wrtFBName,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + fieldCount=ncount_field, name=wrtFBName,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! if(mype==0) print *,'in setvar, allocate fcstField,ibdl=',ibdl,'count=',ncount_field,'wrtFBname=',trim(wrtFBName) allocate(fcstField(ncount_field)) call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), & - fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl, 'nfield=',ncount_field + do n=1, ncount_field ! call ESMF_FieldGet(fcstField(n),typekind=typekind, name=fieldname, & - dimCount=fieldDimCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + dimCount=fieldDimCount,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (index(trim(fieldname),"vector") >0) cycle ! !** for 2D fields @@ -808,14 +796,14 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr82d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + allocate( arrayr42d(ista:iend,jsta:jend)) - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) do j=jsta, jend do i=ista, iend arrayr42d(i,j) = arrayr82d(i,j) @@ -824,58 +812,58 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! Terrain height (*G later) - if(trim(fieldname)=='hgtsfc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) + if(trim(fieldname) == 'hgtsfc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) do j=jsta,jend do i=ista, iend - fis(i,j)=arrayr42d(i,j) + fis(i,j) = arrayr42d(i,j) enddo enddo endif ! Surface pressure ! if(trim(fieldname)=='pressfc') then -! !$omp parallel do private(i,j) +!!$omp parallel do private(i,j) ! do j=jsta,jend ! do i=ista, iend -! pint(i,j)=arrayr42d(i,j) +! pint(i,j) = arrayr42d(i,j) ! enddo ! enddo ! endif ! PBL height using nemsio - if(trim(fieldname)=='hpbl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) + if(trim(fieldname) == 'hpbl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) do j=jsta,jend do i=ista, iend - pblh(i,j)=arrayr42d(i,j) + pblh(i,j) = arrayr42d(i,j) enddo enddo endif ! frictional velocity - if(trim(fieldname)=='fricv') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) + if(trim(fieldname) == 'fricv') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) do j=jsta,jend do i=ista, iend - ustar(i,j)=arrayr42d(i,j) + ustar(i,j) = arrayr42d(i,j) enddo enddo endif ! roughness length - if(trim(fieldname)=='sfcr') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) + if(trim(fieldname) == 'sfcr') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) do j=jsta,jend do i=ista, iend - z0(i,j)=arrayr42d(i,j) + z0(i,j) = arrayr42d(i,j) enddo enddo endif ! sfc exchange coeff - if(trim(fieldname)=='sfexc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) + if(trim(fieldname) == 'sfexc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) do j=jsta,jend do i=ista, iend sfcexc(i,j)=arrayr42d(i,j) @@ -884,18 +872,18 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! aerodynamic conductance - if(trim(fieldname)=='acond') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) + if(trim(fieldname) == 'acond') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) do j=jsta,jend do i=ista, iend - acond(i,j)=arrayr42d(i,j) + acond(i,j) = arrayr42d(i,j) enddo enddo endif ! surface potential T - if(trim(fieldname)=='tmpsfc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) + if(trim(fieldname) == 'tmpsfc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -906,114 +894,114 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! convective precip in m per physics time step - if(trim(fieldname)=='cpratb_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate) + if(trim(fieldname) == 'cpratb_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) & - avgcprate(i,j) = arrayr42d(i,j) * (dtq2*0.001) + avgcprate(i,j) = arrayr42d(i,j) * dtq2001 enddo enddo endif ! continuous bucket convective precip in m per physics time step - if(trim(fieldname)=='cprat_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate_cont) + if(trim(fieldname) =='cprat_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgcprate_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) + avgcprate_cont(i,j) = arrayr42d(i,j) * dtq2001 endif enddo enddo endif ! time averaged bucketed precip rate - if(trim(fieldname)=='prateb_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec) + if(trim(fieldname) == 'prateb_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec(i,j) = arrayr42d(i,j) * (dtq2*0.001) + avgprec(i,j) = arrayr42d(i,j) * dtq2001 endif enddo enddo endif ! time averaged continuous precip rate in m per physics time step - if(trim(fieldname)=='prate_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec_cont) + if(trim(fieldname) == 'prate_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) + avgprec_cont(i,j) = arrayr42d(i,j) * dtq2001 endif enddo enddo endif ! precip rate in m per physics time step - if(trim(fieldname)=='tprcp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,prec) + if(trim(fieldname) == 'tprcp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,prec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - prec(i,j) = arrayr42d(i,j) * (dtq2*0.001) * 1000./dtp + prec(i,j) = arrayr42d(i,j) * (dtq2001 * 1000./dtp) endif enddo enddo endif ! convective precip rate in m per physics time step - if(trim(fieldname)=='cnvprcp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,cprate) + if(trim(fieldname) == 'cnvprcp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,cprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2*0.001) * 1000./dtp + cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2001 * 1000./dtp) endif enddo enddo endif ! inst snow water eqivalent - if(trim(fieldname)=='weasd') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) + if(trim(fieldname) == 'weasd') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend sno(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j)==0.)sno(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) sno(i,j) = spval enddo enddo endif ! ave snow cover - if(trim(fieldname)=='snowc_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) + if(trim(fieldname) == 'snowc_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend snoavg(i,j) = arrayr42d(i,j) - if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) snoavg(i,j) = spval if (snoavg(i,j) /= spval) snoavg(i,j) = snoavg(i,j)/100. enddo enddo endif ! snow depth in mm - if(trim(fieldname)=='snod') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) + if(trim(fieldname) == 'snod') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend si(i,j) = arrayr42d(i,j) - if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) si(i,j)=spval if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 enddo enddo endif ! 2m potential T (computed later) - if(trim(fieldname)=='tmp2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) + if(trim(fieldname) == 'tmp2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) do j=jsta,jend do i=ista, iend tshltr(i,j) = arrayr42d(i,j) @@ -1022,8 +1010,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! surface potential T - if(trim(fieldname)=='spfh2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) + if(trim(fieldname) == 'spfh2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) do j=jsta,jend do i=ista, iend qshltr(i,j) = arrayr42d(i,j) @@ -1032,8 +1020,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! mid day avg albedo in fraction - if(trim(fieldname)=='albdo_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) + if(trim(fieldname) == 'albdo_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) do j=jsta,jend do i=ista, iend avgalbedo(i,j) = arrayr42d(i,j) @@ -1045,8 +1033,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname)=='tcdc_aveclm') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) + if(trim(fieldname) == 'tcdc_aveclm') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) do j=jsta,jend do i=ista, iend avgtcdc(i,j) = arrayr42d(i,j) @@ -1058,8 +1046,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! maximum snow albedo in fraction - if(trim(fieldname)=='snoalb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) + if(trim(fieldname) == 'snoalb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) do j=jsta,jend do i=ista, iend mxsnal(i,j) = arrayr42d(i,j) @@ -1071,8 +1059,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave high cloud fraction - if(trim(fieldname)=='tcdc_avehcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) + if(trim(fieldname) == 'tcdc_avehcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) do j=jsta,jend do i=ista, iend avgcfrach(i,j) = arrayr42d(i,j) @@ -1084,8 +1072,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave low cloud fraction - if(trim(fieldname)=='tcdc_avelcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) + if(trim(fieldname) == 'tcdc_avelcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracl(i,j) = arrayr42d(i,j) @@ -1097,8 +1085,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave middle cloud fraction - if(trim(fieldname)=='tcdc_avemcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) + if(trim(fieldname) == 'tcdc_avemcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracm(i,j) = arrayr42d(i,j) @@ -1110,8 +1098,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst convective cloud fraction - if(trim(fieldname)=='tcdccnvcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) + if(trim(fieldname) == 'tcdccnvcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) do j=jsta,jend do i=ista, iend cnvcfr(i,j) = arrayr42d(i,j) @@ -1123,8 +1111,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! slope type - if(trim(fieldname)=='sltyp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) + if(trim(fieldname) == 'sltyp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1137,8 +1125,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname)=='cnwat') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) + if(trim(fieldname) == 'cnwat') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) do j=jsta,jend do i=ista, iend cmc(i,j) = arrayr42d(i,j) @@ -1149,8 +1137,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! frozen precip fraction - if(trim(fieldname)=='cpofp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) + if(trim(fieldname) == 'cpofp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -1164,8 +1152,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sea ice skin temperature - if(trim(fieldname)=='tisfc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) + if(trim(fieldname) == 'tisfc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) do j=jsta,jend do i=ista,iend if (arrayr42d(i,j) /= spval) then @@ -1179,8 +1167,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation fraction - if(trim(fieldname)=='veg') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) + if(trim(fieldname) == 'veg') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) do j=jsta,jend do i=ista, iend vegfrc(i,j) = arrayr42d(i,j) @@ -1195,8 +1183,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname)=='soill1') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname) == 'soill1') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,1) = arrayr42d(i,j) @@ -1206,8 +1194,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname)=='soill2') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname) == 'soill2') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,2) = arrayr42d(i,j) @@ -1217,8 +1205,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname)=='soill3') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname) == 'soill3') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,3) = arrayr42d(i,j) @@ -1228,8 +1216,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname)=='soill4') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname) == 'soill4') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,4) = arrayr42d(i,j) @@ -1239,8 +1227,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname)=='soilw1') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname) == 'soilw1') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,1) = arrayr42d(i,j) @@ -1250,8 +1238,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname)=='soilw2') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname) == 'soilw2') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,2) = arrayr42d(i,j) @@ -1261,8 +1249,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname)=='soilw3') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname) == 'soilw3') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,3) = arrayr42d(i,j) @@ -1272,8 +1260,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname)=='soilw4') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname) == 'soilw4') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,4) = arrayr42d(i,j) @@ -1283,8 +1271,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname)=='soilt1') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname) == 'soilt1') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,1) = arrayr42d(i,j) @@ -1295,8 +1283,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname)=='soilt2') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname) == 'soilt2') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,2) = arrayr42d(i,j) @@ -1307,8 +1295,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname)=='soilt3') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname) == 'soilt3') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,3) = arrayr42d(i,j) @@ -1319,8 +1307,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname)=='soilt4') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname) == 'soilt4') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,4) = arrayr42d(i,j) @@ -1332,7 +1320,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged incoming sfc longwave if(trim(fieldname)=='dlwrf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) do j=jsta,jend do i=ista, iend alwin(i,j) = arrayr42d(i,j) @@ -1341,8 +1329,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc longwave - if(trim(fieldname)=='dlwrf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) + if(trim(fieldname) == 'dlwrf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) do j=jsta,jend do i=ista, iend rlwin(i,j) = arrayr42d(i,j) @@ -1351,8 +1339,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc longwave, CLDRAD puts a minus sign - if(trim(fieldname)=='ulwrf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) + if(trim(fieldname) == 'ulwrf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) do j=jsta,jend do i=ista, iend alwout(i,j) = arrayr42d(i,j) @@ -1362,8 +1350,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc longwave - if(trim(fieldname)=='ulwrf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) + if(trim(fieldname) == 'ulwrf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) do j=jsta,jend do i=ista, iend radot(i,j) = arrayr42d(i,j) @@ -1372,8 +1360,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing model top longwave - if(trim(fieldname)=='ulwrf_avetoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) + if(trim(fieldname) == 'ulwrf_avetoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) do j=jsta,jend do i=ista, iend alwtoa(i,j) = arrayr42d(i,j) @@ -1382,8 +1370,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc shortwave - if(trim(fieldname)=='dswrf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) + if(trim(fieldname) == 'dswrf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) do j=jsta,jend do i=ista, iend aswin(i,j) = arrayr42d(i,j) @@ -1392,8 +1380,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc shortwave - if(trim(fieldname)=='dswrf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) + if(trim(fieldname) == 'dswrf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) do j=jsta,jend do i=ista, iend rswin(i,j) = arrayr42d(i,j) @@ -1402,8 +1390,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc uv-b - if(trim(fieldname)=='duvb_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) + if(trim(fieldname) == 'duvb_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) do j=jsta,jend do i=ista, iend auvbin(i,j) = arrayr42d(i,j) @@ -1412,8 +1400,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc clear sky uv-b - if(trim(fieldname)=='cduvb_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) + if(trim(fieldname) == 'cduvb_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) do j=jsta,jend do i=ista, iend auvbinc(i,j) = arrayr42d(i,j) @@ -1422,8 +1410,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc shortwave,CLDRAD puts a minus sign - if(trim(fieldname)=='uswrf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) + if(trim(fieldname) == 'uswrf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) do j=jsta,jend do i=ista, iend aswout(i,j) = arrayr42d(i,j) @@ -1433,8 +1421,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc shortwave - if(trim(fieldname)=='uswrf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) + if(trim(fieldname) == 'uswrf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) do j=jsta,jend do i=ista, iend rswout(i,j) = arrayr42d(i,j) @@ -1443,8 +1431,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged model top incoming shortwave - if(trim(fieldname)=='dswrf_avetoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) + if(trim(fieldname) == 'dswrf_avetoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) do j=jsta,jend do i=ista, iend aswintoa(i,j) = arrayr42d(i,j) @@ -1453,8 +1441,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ime averaged model top outgoing shortwave - if(trim(fieldname)=='uswrf_avetoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) + if(trim(fieldname) == 'uswrf_avetoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) do j=jsta,jend do i=ista, iend aswtoa(i,j) = arrayr42d(i,j) @@ -1464,8 +1452,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface sensible heat flux, multiplied by -1 because ! wrf model fluxhas reversed sign convention using gfsio - if(trim(fieldname)=='shtfl_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) + if(trim(fieldname) == 'shtfl_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) do j=jsta,jend do i=ista, iend sfcshx(i,j) = arrayr42d(i,j) @@ -1475,8 +1463,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface sensible heat flux - if(trim(fieldname)=='shtfl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) + if(trim(fieldname) == 'shtfl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) do j=jsta,jend do i=ista, iend twbs(i,j) = arrayr42d(i,j) @@ -1487,8 +1475,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface latent heat flux, multiplied by -1 because ! wrf model flux has reversed sign vonvention using gfsio - if(trim(fieldname)=='lhtfl_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) + if(trim(fieldname) == 'lhtfl_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) do j=jsta,jend do i=ista, iend sfclhx(i,j) = arrayr42d(i,j) @@ -1498,8 +1486,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface latent heat flux - if(trim(fieldname)=='lhtfl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) + if(trim(fieldname) == 'lhtfl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) do j=jsta,jend do i=ista, iend qwbs(i,j) = arrayr42d(i,j) @@ -1509,30 +1497,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged ground heat flux - if(trim(fieldname)=='gflux_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) + if(trim(fieldname) == 'gflux_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend subshx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) subshx(i,j) = spval enddo enddo endif ! inst ground heat flux - if(trim(fieldname)=='gflux') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) + if(trim(fieldname) == 'gflux') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend grnflx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) grnflx(i,j) = spval enddo enddo endif ! time averaged zonal momentum flux - if(trim(fieldname)=='uflx_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) + if(trim(fieldname) == 'uflx_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) do j=jsta,jend do i=ista, iend sfcux(i,j) = arrayr42d(i,j) @@ -1541,8 +1529,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional momentum flux - if(trim(fieldname)=='vflx_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) + if(trim(fieldname) == 'vflx_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) do j=jsta,jend do i=ista, iend sfcvx(i,j) = arrayr42d(i,j) @@ -1551,8 +1539,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged zonal gravity wave stress - if(trim(fieldname)=='u-gwd_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) + if(trim(fieldname) == 'u-gwd_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) do j=jsta,jend do i=ista, iend gtaux(i,j) = arrayr42d(i,j) @@ -1561,8 +1549,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional gravity wave stress - if(trim(fieldname)=='v-gwd_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) + if(trim(fieldname) == 'v-gwd_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) do j=jsta,jend do i=ista, iend gtauy(i,j) = arrayr42d(i,j) @@ -1571,30 +1559,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged accumulated potential evaporation - if(trim(fieldname)=='pevpr_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) + if(trim(fieldname) == 'pevpr_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgpotevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgpotevp(i,j) = spval enddo enddo endif ! inst potential evaporation - if(trim(fieldname)=='pevpr') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) + if(trim(fieldname) == 'pevpr') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend potevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) potevp(i,j) = spval enddo enddo endif ! 10 m u - if(trim(fieldname)=='ugrd10m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) + if(trim(fieldname) == 'ugrd10m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) do j=jsta,jend do i=ista, iend u10(i,j) = arrayr42d(i,j) @@ -1604,8 +1592,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! 10 m v - if(trim(fieldname)=='vgrd10m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) + if(trim(fieldname) == 'vgrd10m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) do j=jsta,jend do i=ista, iend v10(i,j) = arrayr42d(i,j) @@ -1615,8 +1603,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation type - if(trim(fieldname)=='vtype') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) + if(trim(fieldname) == 'vtype') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1629,8 +1617,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil type - if(trim(fieldname)=='sotyp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) + if(trim(fieldname) == 'sotyp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1643,8 +1631,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud top pressure - if(trim(fieldname)=='prescnvclt') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) + if(trim(fieldname) == 'prescnvclt') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) do j=jsta,jend do i=ista, iend ptop(i,j) = arrayr42d(i,j) @@ -1654,8 +1642,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud bottom pressure - if(trim(fieldname)=='prescnvclb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) + if(trim(fieldname) == 'prescnvclb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) do j=jsta,jend do i=ista, iend pbot(i,j) = arrayr42d(i,j) @@ -1665,8 +1653,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top pressure - if(trim(fieldname)=='pres_avelct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) + if(trim(fieldname) == 'pres_avelct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) do j=jsta,jend do i=ista, iend ptopl(i,j) = arrayr42d(i,j) @@ -1675,8 +1663,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud bottom pressure - if(trim(fieldname)=='pres_avelcb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) + if(trim(fieldname) == 'pres_avelcb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) do j=jsta,jend do i=ista, iend pbotl(i,j) = arrayr42d(i,j) @@ -1685,8 +1673,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top temperature - if(trim(fieldname)=='tmp_avelct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) + if(trim(fieldname) == 'tmp_avelct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) do j=jsta,jend do i=ista, iend ttopl(i,j) = arrayr42d(i,j) @@ -1695,8 +1683,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top pressure - if(trim(fieldname)=='pres_avemct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) + if(trim(fieldname) == 'pres_avemct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) do j=jsta,jend do i=ista, iend ptopm(i,j) = arrayr42d(i,j) @@ -1705,8 +1693,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud bottom pressure - if(trim(fieldname)=='pres_avemcb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) + if(trim(fieldname) == 'pres_avemcb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) do j=jsta,jend do i=ista, iend pbotm(i,j) = arrayr42d(i,j) @@ -1715,8 +1703,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top temperature - if(trim(fieldname)=='tmp_avemct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) + if(trim(fieldname) == 'tmp_avemct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) do j=jsta,jend do i=ista, iend ttopm(i,j) = arrayr42d(i,j) @@ -1725,8 +1713,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top pressure - if(trim(fieldname)=='pres_avehct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) + if(trim(fieldname) == 'pres_avehct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) do j=jsta,jend do i=ista, iend ptoph(i,j) = arrayr42d(i,j) @@ -1735,8 +1723,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud bottom pressure - if(trim(fieldname)=='pres_avehcb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) + if(trim(fieldname) == 'pres_avehcb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) do j=jsta,jend do i=ista, iend pboth(i,j) = arrayr42d(i,j) @@ -1745,8 +1733,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top temperature - if(trim(fieldname)=='tmp_avehct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) + if(trim(fieldname) == 'tmp_avehct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) do j=jsta,jend do i=ista, iend ttoph(i,j) = arrayr42d(i,j) @@ -1755,8 +1743,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged boundary layer cloud cover - if(trim(fieldname)=='tcdc_avebndcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) + if(trim(fieldname) == 'tcdc_avebndcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) do j=jsta,jend do i=ista, iend pblcfr(i,j) = arrayr42d(i,j) @@ -1766,8 +1754,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! cloud work function - if(trim(fieldname)=='cwork_aveclm') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) + if(trim(fieldname) == 'cwork_aveclm') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) do j=jsta,jend do i=ista, iend cldwork(i,j) = arrayr42d(i,j) @@ -1776,8 +1764,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! water runoff - if(trim(fieldname)=='watr_acc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) + if(trim(fieldname) == 'watr_acc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) do j=jsta,jend do i=ista, iend runoff(i,j) = arrayr42d(i,j) @@ -1787,8 +1775,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max temperature - if(trim(fieldname)=='tmax_max2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) + if(trim(fieldname) == 'tmax_max2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxtshltr(i,j) = arrayr42d(i,j) @@ -1797,8 +1785,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname)=='tmin_min2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) + if(trim(fieldname) == 'tmin_min2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) do j=jsta,jend do i=ista, iend mintshltr(i,j) = arrayr42d(i,j) @@ -1807,8 +1795,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ice thickness - if(trim(fieldname)=='icetk') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) + if(trim(fieldname) == 'icetk') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) do j=jsta,jend do i=ista, iend dzice(i,j) = arrayr42d(i,j) @@ -1817,8 +1805,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! wilting point - if(trim(fieldname)=='wilt') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) + if(trim(fieldname) == 'wilt') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) do j=jsta,jend do i=ista, iend smcwlt(i,j) = arrayr42d(i,j) @@ -1828,8 +1816,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sunshine duration - if(trim(fieldname)=='sunsd_acc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) + if(trim(fieldname) == 'sunsd_acc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) do j=jsta,jend do i=ista, iend suntime(i,j) = arrayr42d(i,j) @@ -1838,8 +1826,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! field capacity - if(trim(fieldname)=='fldcp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) + if(trim(fieldname) == 'fldcp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) do j=jsta,jend do i=ista, iend fieldcapa(i,j) = arrayr42d(i,j) @@ -1849,8 +1837,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible beam downward solar flux - if(trim(fieldname)=='vbdsf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) + if(trim(fieldname) == 'vbdsf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend avisbeamswin(i,j) = arrayr42d(i,j) @@ -1859,8 +1847,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible diffuse downward solar flux - if(trim(fieldname)=='vddsf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) + if(trim(fieldname) == 'vddsf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend avisdiffswin(i,j) = arrayr42d(i,j) @@ -1869,8 +1857,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR beam downward solar flux - if(trim(fieldname)=='nbdsf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) + if(trim(fieldname) == 'nbdsf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend airbeamswin(i,j) = arrayr42d(i,j) @@ -1879,8 +1867,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR diffuse downward solar flux - if(trim(fieldname)=='nddsf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) + if(trim(fieldname) == 'nddsf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend airdiffswin(i,j) = arrayr42d(i,j) @@ -1889,8 +1877,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing LW - if(trim(fieldname)=='csulf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) + if(trim(fieldname) == 'csulf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) do j=jsta,jend do i=ista, iend alwoutc(i,j) = arrayr42d(i,j) @@ -1899,8 +1887,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing LW - if(trim(fieldname)=='csulftoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) + if(trim(fieldname) == 'csulftoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) do j=jsta,jend do i=ista, iend alwtoac(i,j) = arrayr42d(i,j) @@ -1909,8 +1897,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing SW - if(trim(fieldname)=='csusf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) + if(trim(fieldname) == 'csusf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) do j=jsta,jend do i=ista, iend aswoutc(i,j) = arrayr42d(i,j) @@ -1919,8 +1907,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing SW - if(trim(fieldname)=='csusftoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) + if(trim(fieldname) == 'csusftoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) do j=jsta,jend do i=ista, iend aswtoac(i,j) = arrayr42d(i,j) @@ -1929,8 +1917,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming LW - if(trim(fieldname)=='csdlf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) + if(trim(fieldname) == 'csdlf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) do j=jsta,jend do i=ista, iend alwinc(i,j) = arrayr42d(i,j) @@ -1939,8 +1927,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming SW - if(trim(fieldname)=='csdsf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) + if(trim(fieldname) == 'csdsf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) do j=jsta,jend do i=ista, iend aswinc(i,j) = arrayr42d(i,j) @@ -1949,8 +1937,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max specific humidity - if(trim(fieldname)=='spfhmax_max2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) + if(trim(fieldname) == 'spfhmax_max2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxqshltr(i,j) = arrayr42d(i,j) @@ -1959,8 +1947,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname)=='spfhmin_min2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) + if(trim(fieldname) == 'spfhmin_min2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) do j=jsta,jend do i=ista, iend minqshltr(i,j) = arrayr42d(i,j) @@ -1969,8 +1957,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! storm runoffs - if(trim(fieldname)=='ssrun_acc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) + if(trim(fieldname) == 'ssrun_acc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) do j=jsta,jend do i=ista, iend ssroff(i,j) = arrayr42d(i,j) @@ -1980,8 +1968,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! direct soil evaporation - if(trim(fieldname)=='evbs_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) + if(trim(fieldname) == 'evbs_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgedir(i,j) = arrayr42d(i,j) @@ -1991,8 +1979,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! canopy water evap - if(trim(fieldname)=='evcw_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) + if(trim(fieldname) == 'evcw_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgecan(i,j) = arrayr42d(i,j) @@ -2002,8 +1990,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! plant transpiration - if(trim(fieldname)=='trans_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) + if(trim(fieldname) == 'trans_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgetrans(i,j) = arrayr42d(i,j) @@ -2013,19 +2001,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow sublimation - if(trim(fieldname)=='sbsno_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) + if(trim(fieldname) == 'sbsno_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgesnow(i,j) = arrayr42d(i,j) - if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgesnow(i,j) = spval enddo enddo endif ! total soil moisture - if(trim(fieldname)=='soilm') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) + if(trim(fieldname) == 'soilm') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) do j=jsta,jend do i=ista, iend smstot(i,j) = arrayr42d(i,j) @@ -2035,8 +2023,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow phase change heat flux - if(trim(fieldname)=='snohf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) + if(trim(fieldname) == 'snohf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) do j=jsta,jend do i=ista, iend snopcx(i,j) = arrayr42d(i,j) @@ -2046,19 +2034,17 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! else if (fieldDimCount > gridDimCount) then - else if (fieldDimCount ==3) then + else if (fieldDimCount == 3) then if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr43d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr83d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return allocate(arrayr43d(ista:iend,jsta:jend,kstart:kend)) arrayr43d = 0. do k=kstart,kend - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) do j=jsta,jend do i=ista,iend arrayr43d(i,j,k) = arrayr83d(i,j,k) @@ -2068,8 +2054,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level T - if(trim(fieldname)=='tmp') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) + if(trim(fieldname) == 'tmp') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend @@ -2079,7 +2065,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo !! sig4 - !$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) +!$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) do j=jsta,jend do i=ista, iend tlmh = t(i,j,lm) * t(i,j,lm) @@ -2089,172 +2075,237 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level spfh - if(trim(fieldname)=='spfh') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) + if(trim(fieldname) == 'spfh') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q(i,j,l)=arrayr43d(i,j,l) + q(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level u wind - if(trim(fieldname)=='ugrd') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) + if(trim(fieldname) == 'ugrd') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - uh(i,j,l)=arrayr43d(i,j,l) + uh(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level v wind - if(trim(fieldname)=='vgrd') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) + if(trim(fieldname) == 'vgrd') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - vh(i,j,l)=arrayr43d(i,j,l) + vh(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level pressure thinkness - if(trim(fieldname)=='dpres') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) + if(trim(fieldname) == 'dpres') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - dpres(i,j,l)=arrayr43d(i,j,l) + dpres(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level gh thinkness, model output negative delz - if(trim(fieldname)=='delz') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) + if(trim(fieldname) == 'delz') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - zint(i,j,l)=-1.*arrayr43d(i,j,l) + zint(i,j,l) = -arrayr43d(i,j,l) enddo enddo enddo endif ! model level w - if(trim(fieldname)=='dzdt') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) + if(trim(fieldname) == 'dzdt') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - wh(i,j,l)=arrayr43d(i,j,l) + wh(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level ozone mixing ratio - if(trim(fieldname)=='o3mr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) + if(trim(fieldname) == 'o3mr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - o3(i,j,l)=arrayr43d(i,j,l) + o3(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif -! for GFDL MP - if (imp_physics == 11) then +! for GFDL or MG3 MP +! ------------------ + if (imp_physics == 10 .or. imp_physics == 11) then ! model level cloud water mixing ratio - if(trim(fieldname)=='clwmr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) + if(trim(fieldname) == 'clwmr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqw(i,j,l)=arrayr43d(i,j,l) + qqw(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level ice mixing ratio - if(trim(fieldname)=='icmr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) + if(trim(fieldname) == 'icmr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqi(i,j,l)=arrayr43d(i,j,l) + qqi(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname)=='rwmr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) + if(trim(fieldname) == 'rwmr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqr(i,j,l)=arrayr43d(i,j,l) + qqr(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level snow mixing ratio - if(trim(fieldname)=='snmr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) + if(trim(fieldname) == 'snmr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqs(i,j,l)=arrayr43d(i,j,l) + qqs(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname)=='grle') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) + if(trim(fieldname) == 'grle') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqg(i,j,l)=arrayr43d(i,j,l) + qqg(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + endif !gfdlmp or MG3 mp +! for MG3 MP +! ---------- + if (imp_physics == 10) then + ! model level cloud water mixing ratio number concentration + if(trim(fieldname) == 'clwnc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnw,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqnw(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + ! model level ice mixing ratio number concentration + if(trim(fieldname) == 'icenc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqni,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqni(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + ! model level rain water mixing ratio number concentration + if(trim(fieldname) == 'rwnc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnr,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqnr(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + ! model level snow mixing ratio number concentration + if(trim(fieldname) == 'snnc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqns,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqns(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif -!gfdlmp - endif + + ! model level rain water mixing ratio number concentration + if(trim(fieldname) == 'grlenc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqng,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqng(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + endif ! for MG3 MP ! model level cloud amount - if(trim(fieldname)=='cld_amt') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) + if(trim(fieldname) == 'cld_amt') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - cfr(i,j,l)=arrayr43d(i,j,l) + cfr(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level ref3d - if(trim(fieldname)=='ref3D') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) + if(trim(fieldname) == 'ref3D') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - ref_10cm(i,j,l)=arrayr43d(i,j,l) + ref_10cm(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo @@ -2262,12 +2313,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level ref3d - if(trim(fieldname)=='tke') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) + if(trim(fieldname) == 'tke') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q2(i,j,l)=arrayr43d(i,j,l) + q2(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo @@ -2275,8 +2326,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !3d fields endif -! end loop ncount_field - enddo + enddo ! end loop ncount_field if ( index(trim(wrt_int_state%wrtFB_names(ibdl)),trim(filename_base(1))) > 0) & setvar_atmfile = .true. @@ -2302,46 +2352,33 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,omga,wh,dpres,zint) do j=jsta,jend do i=1,im - omga(i,j,l) = (-1.) * wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) + omga(i,j,l) = - wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) zint(i,j,l) = zint(i,j,l) + zint(i,j,l+1) enddo enddo enddo ! compute pint from top down -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint,pd,spval) do j=jsta,jend do i=1,im pint(i,j,1) = ak5(1) - end do - end do + pd(i,j) = spval + enddo + enddo do l=2,lp1 -!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pint,dpres) + ll = l - 1 +!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,pint,dpres,pmid) do j=jsta,jend do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo - end do - + pint(i,j,l) = pint(i,j,ll) + dpres(i,j,ll) !compute pmid from averaged two layer pint - do l=lm,1,-1 -!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pmid,pint) - do j=jsta,jend - do i=1,im - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) + pmid(i,j,ll) = 0.5*(pint(i,j,ll)+pint(i,j,l)) enddo enddo enddo -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,spval,pt,pd,pint) - do j=jsta,jend - do i=1,im - pd(i,j) = spval - pint(i,j,1) = pt - end do - end do ! print *,'in setvar, pt=',pt,'ak5(lp1)=', ak5(lp1),'ak5(1)=',ak5(1) ! compute alpint @@ -2349,22 +2386,23 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,alpint,pint) do j=jsta,jend do i=1,im - alpint(i,j,l)=log(pint(i,j,l)) - end do - end do - end do + alpint(i,j,l) = log(pint(i,j,l)) + enddo + enddo + enddo ! compute zmid do l=lm,1,-1 -!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,zmid,zint,pmid,alpint) + ll = l + 1 +!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,zmid,zint,pmid,alpint) do j=jsta,jend do i=1,im - zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & - (log(pmid(i,j,l))-alpint(i,j,l+1))/ & - (alpint(i,j,l)-alpint(i,j,l+1)) - end do - end do - end do + zmid(i,j,l) = zint(i,j,ll) + (zint(i,j,l)-zint(i,j,ll)) & + * (log(pmid(i,j,l))-alpint(i,j,ll)) & + / (alpint(i,j,l)-alpint(i,j,ll)) + enddo + enddo + enddo ! print *,'in post_gfs,zmid=',maxval(zmid(1:im,jsta:jend,1)), & ! minval(zmid(1:im,jsta:jend,1)),maxloc(zmid(1:im,jsta:jend,1)), & ! 'zint=',maxval(zint(1:im,jsta:jend,2)),minval(zint(1:im,jsta:jend,1)), & @@ -2390,13 +2428,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo enddo -! compute cwm for gfdlmp - if( imp_physics == 11 ) then +! compute cwm for gfdlmp or MG3 + if( imp_physics == 10 .or. imp_physics == 11) then do l=1,lm !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,ista,iend,cwm,qqg,qqs,qqr,qqi,qqw) do j=jsta,jend do i=ista,iend - cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) + cwm(i,j,l) = qqg(i,j,l) + qqs(i,j,l) + qqr(i,j,l) + qqi(i,j,l) + qqw(i,j,l) enddo enddo enddo @@ -2406,8 +2444,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,lm,pshltr,pint,tshltr) do j=jsta,jend do i=ista, iend - pshltr(I,J)=pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/pshltr(I,J))**CAPA + pshltr(I,J) = pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) + tshltr(i,j) = tshltr(i,j)*(p1000/pshltr(I,J))**CAPA enddo enddo @@ -2418,13 +2456,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if(ptop(i,j) < spval)then do l=1,lm if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j)=l + htop(i,j) = l exit - end if - end do - end if - end do - end do + endif + enddo + endif + enddo + enddo ! hbot do j=jsta,jend From 7c258bd80bba7ef20f475fac4fb9b0ddcc7a770b Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 4 Aug 2020 15:18:00 +0000 Subject: [PATCH 72/91] changing z0ice to cm --- atmos_model.F90 | 2 +- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 7c6962fe8..b31e0352f 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1661,7 +1661,7 @@ subroutine assign_importdata(rc) real(kind=IPD_kind_phys), dimension(:,:), pointer :: datar8 real(kind=IPD_kind_phys) :: tem, ofrac logical found, isFieldCreated, lcpl_fice - real (kind=IPD_kind_phys), parameter :: z0ice=0.011 + real (kind=IPD_kind_phys), parameter :: z0ice=1.1 ! (in cm) ! !------------------------------------------------------------------------------ ! diff --git a/ccpp/physics b/ccpp/physics index 4b11e8491..04f660ba4 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 4b11e849183fa7635c0db6fd0631159159ec126c +Subproject commit 04f660ba4e305028a3c8064239619266971226d6 diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 715f91ddd..02eb00e00 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -649,7 +649,7 @@ subroutine GFS_physics_driver & hflxq, evapq, hffac, hefac real (kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 real (kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 - real (kind=kind_phys), parameter :: z0ice=0.011 + real (kind=kind_phys), parameter :: z0ice=1.1 ! !=============================================================================== From a77396a1ae7dcd6444aa580f5bc143ec4a430c77 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 4 Aug 2020 15:22:42 +0000 Subject: [PATCH 73/91] changing z0ice to cm --- atmos_model.F90 | 2 +- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 7c6962fe8..b31e0352f 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -1661,7 +1661,7 @@ subroutine assign_importdata(rc) real(kind=IPD_kind_phys), dimension(:,:), pointer :: datar8 real(kind=IPD_kind_phys) :: tem, ofrac logical found, isFieldCreated, lcpl_fice - real (kind=IPD_kind_phys), parameter :: z0ice=0.011 + real (kind=IPD_kind_phys), parameter :: z0ice=1.1 ! (in cm) ! !------------------------------------------------------------------------------ ! diff --git a/ccpp/physics b/ccpp/physics index 4b11e8491..04f660ba4 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 4b11e849183fa7635c0db6fd0631159159ec126c +Subproject commit 04f660ba4e305028a3c8064239619266971226d6 diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 715f91ddd..02eb00e00 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -649,7 +649,7 @@ subroutine GFS_physics_driver & hflxq, evapq, hffac, hefac real (kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 real (kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 - real (kind=kind_phys), parameter :: z0ice=0.011 + real (kind=kind_phys), parameter :: z0ice=1.1 ! !=============================================================================== From 0e660373bced07d3aa239b9f0c67a98d1f62c622 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 10 Aug 2020 11:05:01 -0400 Subject: [PATCH 74/91] after updating sfcsub.F in ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index b9ff5e713..d3dcae7ea 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit b9ff5e713a8e5f1b5c8863b624c0c6522b6532b4 +Subproject commit d3dcae7ea20e27b9f4c774cea52acf7389e6d9e9 From e0b7e3778fc41da9766e8dcf93463fa6282b3c36 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 10 Aug 2020 12:16:23 -0400 Subject: [PATCH 75/91] a fix in wv_saturation.F - impact on resuls --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index d3dcae7ea..c3ddc93d8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit d3dcae7ea20e27b9f4c774cea52acf7389e6d9e9 +Subproject commit c3ddc93d88012e45daca4b115b83074c019fb8bb From 956d06b0b3860d43814cbf99c80c761644483c70 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 10 Aug 2020 12:48:24 -0400 Subject: [PATCH 76/91] moving definition of kp inside ifdef in wv_saturation.F --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index c3ddc93d8..f3b797ffd 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit c3ddc93d88012e45daca4b115b83074c019fb8bb +Subproject commit f3b797ffda59e9c0e0fe02b15564f530ef569229 From ee2a35fc0efd17aac81878beb55b89eeba106350 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 11 Aug 2020 10:10:17 -0400 Subject: [PATCH 77/91] updating gitmodules --- .gitmodules | 8 ++++---- ccpp/physics | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index c3ceea468..ad41e5c86 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,11 +1,11 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere - branch = SM_Jul232020 + url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere + branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/SMoorthi-emc/ccpp-framework - branch = SM_Jul092020 + url = https://github.com/NCAR/ccpp-framework + branch = master [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics diff --git a/ccpp/physics b/ccpp/physics index 04f660ba4..f3b797ffd 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 04f660ba4e305028a3c8064239619266971226d6 +Subproject commit f3b797ffda59e9c0e0fe02b15564f530ef569229 From 515308e3912e72bc8166b95b06c9000e515e70c0 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 24 Aug 2020 01:00:32 +0000 Subject: [PATCH 78/91] changing ver=3 to ver=4 in suite_FV3_GFS_cpld_rasmgshocnsst.xml --- ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml index 5b3b63528..a08956dfa 100644 --- a/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml +++ b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml @@ -1,6 +1,6 @@ - + From 824b63453c214474f1b0c8705537c5ef5d665ce9 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 26 Aug 2020 00:49:51 +0000 Subject: [PATCH 79/91] updatin gitmodules --- .gitmodules | 2 +- ccpp/physics | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index ad41e5c86..8b16cb27c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -9,4 +9,4 @@ [submodule "ccpp/physics"] path = ccpp/physics url = https://github.com/SMoorthi-EMC/ccpp-physics - branch = SM_Jul302020 + branch = SM_Aug252020 diff --git a/ccpp/physics b/ccpp/physics index f3b797ffd..8617587ed 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit f3b797ffda59e9c0e0fe02b15564f530ef569229 +Subproject commit 8617587edb95aa097b7bbc2735990393bc6d9b90 From 697ad6bb9ae3fdd750256d3c72c8e25b2cc9d466 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 31 Aug 2020 00:34:44 +0000 Subject: [PATCH 80/91] updating .gitmodules --- .gitmodules | 4 ++-- atmos_cubed_sphere | 2 +- ccpp/driver/CCPP_driver.F90 | 12 ++++++------ ccpp/physics | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/.gitmodules b/.gitmodules index 8b16cb27c..f5955ffb8 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,7 +1,7 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere - branch = dev/emc + url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere + branch = SM_Aug272020 [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/NCAR/ccpp-framework diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 8b59ebc03..93943e585 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 8b59ebc039dafe1c20ed6dd21cb38ca564852b98 +Subproject commit 93943e5855a85e9cd0b28b679c2da4cc16938e60 diff --git a/ccpp/driver/CCPP_driver.F90 b/ccpp/driver/CCPP_driver.F90 index 8e45d9382..89c41672f 100644 --- a/ccpp/driver/CCPP_driver.F90 +++ b/ccpp/driver/CCPP_driver.F90 @@ -93,7 +93,7 @@ subroutine CCPP_step (step, nblks, ierr) end do end do - else if (trim(step)=="physics_init") then + else if (trim(step)=="physics_init") then ! Since the physics init steps are independent of the blocking structure, ! we can use cdata_domain here. Since we don't use threading on the outside, @@ -107,7 +107,7 @@ subroutine CCPP_step (step, nblks, ierr) return end if - else if (trim(step)=="time_vary") then + else if (trim(step)=="time_vary") then ! Since the time_vary steps only use data structures for all blocks (except the ! CCPP-internal variables ccpp_error_flag and ccpp_error_message, which are defined @@ -123,8 +123,8 @@ subroutine CCPP_step (step, nblks, ierr) return end if - ! Radiation and stochastic physics - else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then + ! Radiation and stochastic physics + else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then ! Set number of threads available to physics schemes to one, ! because threads are used on the outside for blocking @@ -162,8 +162,8 @@ subroutine CCPP_step (step, nblks, ierr) !$OMP end parallel if (ierr/=0) return - ! Finalize - else if (trim(step)=="finalize") then + ! Finalize + else if (trim(step)=="finalize") then ! Loop over blocks, don't use threading on the outside but allowing threading ! inside the finalization, similar to what is done for the initialization diff --git a/ccpp/physics b/ccpp/physics index 8617587ed..f94cc6105 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 8617587edb95aa097b7bbc2735990393bc6d9b90 +Subproject commit f94cc61050e504279e29d22d0ef2b248be8e3be7 From e9ef74759cfe682ca21d671327977d922756e0a8 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 1 Sep 2020 16:28:23 +0000 Subject: [PATCH 81/91] fix some tsfc related issues --- atmos_model.F90 | 18 +++++++------- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 6 +++-- gfsphysics/GFS_layer/GFS_typedefs.F90 | 4 ++-- io/FV3GFS_io.F90 | 26 ++++++++++++--------- 4 files changed, 31 insertions(+), 23 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 900c9143e..0948b00a8 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -99,13 +99,13 @@ module atmos_model_mod IPD_interstitial => GFS_interstitial use IPD_driver, only: IPD_initialize, IPD_initialize_rst use CCPP_driver, only: CCPP_step, non_uniform_blocks + +use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper #else use IPD_driver, only: IPD_initialize, IPD_initialize_rst, IPD_step use physics_abstraction_layer, only: time_vary_step, radiation_step1, physics_step1, physics_step2 #endif -use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper - use FV3GFS_io_mod, only: FV3GFS_restart_read, FV3GFS_restart_write, & FV3GFS_IPD_checksum, & FV3GFS_diag_register, FV3GFS_diag_output, & @@ -291,14 +291,15 @@ subroutine update_atmos_radiation_physics (Atmos) #ifdef CCPP call CCPP_step (step="time_vary", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP time_vary step failed') + +!--- call stochastic physics pattern generation / cellular automata + call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block) + #else Func1d => time_vary_step call IPD_step (IPD_Control, IPD_Data(:), IPD_Diag, IPD_Restart, IPD_func1d=Func1d) #endif -!--- call stochastic physics pattern generation / cellular automata - call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block) - !--- if coupled, assign coupled fields if( IPD_Control%cplflx .or. IPD_Control%cplwav ) then @@ -623,13 +624,14 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) #ifdef CCPP call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, & IPD_Interstitial, commglobal, mpp_npes(), Init_parm) -#else - call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) -#endif !--- Initialize stochastic physics pattern generation / cellular automata for first time step call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block) +#else + call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) +#endif + Atmos%Diag => IPD_Diag Atm(mygrid)%flagstruct%do_skeb = IPD_Control%do_skeb diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 02eb00e00..05dcdcdb6 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -2191,6 +2191,7 @@ subroutine GFS_physics_driver & ! Sfcprop%tprcp(i) = tprcp3(i,1) Sfcprop%tsfco(i) = tsfc3(i,1) Sfcprop%tisfc(i) = tsfc3(i,1) + Sfcprop%tsfc(i) = tsfc3(i,1) elseif (islmsk(i) == 0) then k = 3 Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake (and ocean when uncoupled) @@ -2198,6 +2199,7 @@ subroutine GFS_physics_driver & ! Sfcprop%tprcp(i) = tprcp3(i,3) Sfcprop%tisfc(i) = tsfc3(i,3) Sfcprop%tsfcl(i) = tsfc3(i,3) + Sfcprop%tsfc(i) = tsfc3(i,3) else k = 2 stress(i) = stress3(i,2) @@ -2222,7 +2224,7 @@ subroutine GFS_physics_driver & evap(i) = evap3(i,k) hflx(i) = hflx3(i,k) qss(i) = qss3(i,k) - Sfcprop%tsfc(i) = tsfc3(i,k) +! Sfcprop%tsfc(i) = tsfc3(i,k) Sfcprop%zorll(i) = zorl3(i,1) Sfcprop%zorli(i) = zorl3(i,2) @@ -2238,7 +2240,7 @@ subroutine GFS_physics_driver & stress(i) = txi *stress3(i,2) + txo * stress3(i,3) qss(i) = txi * qss3(i,2) + txo * qss3(i,3) ep1d(i) = txi * ep1d3(i,2) + txo * ep1d3(i,3) - Sfcprop%zorl(i) = txi*zorl3(i,2) + txo*zorl3(i,3) + Sfcprop%zorl(i) = txi * zorl3(i,2) + txo * zorl3(i,3) endif elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 3c1252b1e..5545781fd 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -1551,9 +1551,9 @@ module GFS_typedefs #ifdef CCPP real (kind=kind_phys), pointer :: TRAIN (:,:) => null() !< accumulated stratiform T tendency (K s-1) #endif -#ifdef CCPP +!#ifdef CCPP real (kind=kind_phys), pointer :: cldfra (:,:) => null() !< instantaneous 3D cloud fraction -#endif +!#endif !--- MP quantities for 3D diagnositics real (kind=kind_phys), pointer :: refl_10cm(:,:) => null() !< instantaneous refl_10cm ! diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index e0898c3f6..472f941ea 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1077,16 +1077,16 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if (Sfcprop(nb)%lakefrac(ix) > zero) then Sfcprop(nb)%oceanfrac(ix) = zero ! lake & ocean don't coexist in a cell - if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) then - Sfcprop(nb)%fice(ix) = zero - if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 - endif +! if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) then +! Sfcprop(nb)%fice(ix) = zero +! if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 +! endif else Sfcprop(nb)%oceanfrac(ix) = one - Sfcprop(nb)%landfrac(ix) - if (Sfcprop(nb)%fice(ix) < Model%min_seaice) then - Sfcprop(nb)%fice(ix) = zero - if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 - endif +! if (Sfcprop(nb)%fice(ix) < Model%min_seaice) then +! Sfcprop(nb)%fice(ix) = zero +! if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 +! endif endif ! !--- NSSTM variables @@ -1365,7 +1365,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) ! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) ! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) ! Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) -! Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) if (Sfcprop(nb)%slmsk(ix) == 1) then Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) @@ -1374,8 +1374,12 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & + Sfcprop(nb)%zorlo(ix) * tem - Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & - + Sfcprop(nb)%tsfco(ix) * tem + if (Sfcprop(nb)%fice(ix) > min(Model%min_seaice,Model%min_lakeice)) then + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + endif + +! Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & +! + Sfcprop(nb)%tsfco(ix) * tem endif enddo enddo From 70dc9b8f82ddd15148e277103162e0388a0bfe55 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 3 Sep 2020 16:33:52 +0000 Subject: [PATCH 82/91] creating a new brnach for restart fix PR --- .gitmodules | 8 ++++---- atmos_cubed_sphere | 2 +- ccpp/physics | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index f5955ffb8..d253f6966 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,12 +1,12 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere - branch = SM_Aug272020 + url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere + branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/NCAR/ccpp-framework branch = master [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/SMoorthi-EMC/ccpp-physics - branch = SM_Aug252020 + url = https://github.com/NCAR/ccpp-physics + branch = master diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 93943e585..8b59ebc03 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 93943e5855a85e9cd0b28b679c2da4cc16938e60 +Subproject commit 8b59ebc039dafe1c20ed6dd21cb38ca564852b98 diff --git a/ccpp/physics b/ccpp/physics index f94cc6105..c555881c1 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit f94cc61050e504279e29d22d0ef2b248be8e3be7 +Subproject commit c555881c1a710d9090f2bdea78f6a5c663f3148a From 445e5d344de1e95d9332422ae6201809fd9a7654 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 4 Sep 2020 10:50:30 +0000 Subject: [PATCH 83/91] fixing a compilation bug --- atmos_model.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 0cb77f805..a0a9b3895 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -293,8 +293,8 @@ subroutine update_atmos_radiation_physics (Atmos) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP time_vary step failed') !--- call stochastic physics pattern generation / cellular automata - call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block) - if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') + call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) + if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') #else Func1d => time_vary_step From 26887d664b8ab9bbf684767abed0efb027b3854f Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 4 Sep 2020 15:43:53 +0000 Subject: [PATCH 84/91] replacing post_gfs.F90 by fv3atm/develop version --- io/post_gfs.F90 | 922 +++++++++++++++++++++++------------------------- 1 file changed, 442 insertions(+), 480 deletions(-) diff --git a/io/post_gfs.F90 b/io/post_gfs.F90 index 248ce6d06..76dd0251c 100644 --- a/io/post_gfs.F90 +++ b/io/post_gfs.F90 @@ -112,20 +112,19 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & !----------------------------------------------------------------------- ! ! if(mype==0) print *,'in post_run,be post_alctvars, dim=',wrt_int_state%im, & -! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & -! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & +! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & +! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & ! 'jstagrp=',jstagrp,'jendgrp=',jendgrp - - call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & - wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & - mpicomp,jts,jte,jstagrp,jendgrp) + call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & + wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & + mpicomp,jts,jte,jstagrp,jendgrp) ! !----------------------------------------------------------------------- !*** read namelist for pv,th,po !----------------------------------------------------------------------- ! - log_postalct = .true. - first_grbtbl = .true. + log_postalct = .true. + first_grbtbl = .true. read_postcntrl = .true. ! ENDIF @@ -138,16 +137,16 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & ifmin = mynfmin if (ifhr == 0 ) ifmin = 0 if(mype==0) print *,'bf set_postvars,ifmin=',ifmin,'ifhr=',ifhr - setvar_atmfile = .false. - setvar_sfcfile = .false. + setvar_atmfile=.false. + setvar_sfcfile=.false. call set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & - setvar_sfcfile) + setvar_sfcfile) ! print *,'af set_postvars,setvar_atmfile=',setvar_atmfile, & ! 'setvar_sfcfile=',setvar_sfcfile ! if (setvar_atmfile.and.setvar_sfcfile) then -! 20190807 need to call microinit only for Ferrier microphysics +! 20190807 no need to call microinit for GFDLMP ! call MICROINIT ! if(grib=="grib2" .and. read_postcntrl) then @@ -240,62 +239,66 @@ subroutine post_getattr_gfs(wrt_int_state, fldbundle) ! look at the field bundle attributes call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, Count=attcount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__,file=__FILE__))return ! bail out ! aklen=0. do i=1, attCount - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & - typekind=typekind, itemCount=n, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return + call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & + attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & + typekind=typekind, itemCount=n, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__,file=__FILE__))return ! bail out if (typekind==ESMF_TYPEKIND_I4 ) then - if(n == 1) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, rc=rc) - if (trim(attName) == 'ncnsto') wrt_int_state%ntrac = varival - if (trim(attName) == 'ncld') wrt_int_state%ncld = varival - if (trim(attName) == 'nsoil') wrt_int_state%nsoil = varival - if (trim(attName) == 'fhzero') wrt_int_state%fhzero = varival - if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics = varival + name=trim(attName), value=varival, rc=rc) + if (trim(attName) == 'ncnsto') wrt_int_state%ntrac=varival + if (trim(attName) == 'ncld') wrt_int_state%ncld=varival + if (trim(attName) == 'nsoil') wrt_int_state%nsoil=varival + if (trim(attName) == 'fhzero') wrt_int_state%fhzero=varival + if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics=varival endif - else if (typekind == ESMF_TYPEKIND_R4) then - if(n == 1) then + else if (typekind==ESMF_TYPEKIND_R4) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr4val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + name=trim(attName), value=varr4val, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr4val endif - else if(n > 1) then + else if(n>1) then if(trim(attName) =="ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 - else if(trim(attName) == "bk") then + else if(trim(attName) =="bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) allocate(wrt_int_state%bk(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%bk, rc=rc) + name=trim(attName), valueList=wrt_int_state%bk, rc=rc) endif endif - else if (typekind == ESMF_TYPEKIND_R8) then - if(n == 1) then + else if (typekind==ESMF_TYPEKIND_R8) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & name=trim(attName), value=varr8val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr8val endif - else if(n > 1) then - if(trim(attName) == "ak") then + else if(n>1) then + if(trim(attName) =="ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 else if(trim(attName) =="bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) @@ -329,8 +332,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use vrbls3d, only: t, q, uh, vh, wh, alpint, dpres, zint, zmid, o3, & qqr, qqs, cwm, qqi, qqw, qqg, omga, cfr, pmid, & q2, rlwtt, rswtt, tcucn, tcucns, train, el_pbl, & - pint, exch_h, ref_10cm, & - qqnw, qqni, qqnr, qqns, qqng + pint, exch_h, ref_10cm use vrbls2d, only: f, pd, sigt4, fis, pblh, ustar, z0, ths, qs, twbs,& qwbs, avgcprate, cprate, avgprec, prec, lspa, sno,& cldefi, th10, q10, tshltr, pshltr, tshltr, albase,& @@ -358,11 +360,11 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use soil, only: sldpth, sh2o, smc, stc use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice use ctlblk_mod, only: im, jm, lm, lp1, jsta, jend, jsta_2l, jend_2u, jsta_m,jend_m, & - lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & - tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & + lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & + tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & ardlw, ardsw, asrfc, avrain, avcnvc, iSF_SURFACE_PHYSICS,& - td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & - alsl, spl, ihrst + td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & + alsl, spl, ihrst use params_mod, only: erad, dtr, capa, p1000 use gridspec_mod,only: latstart, latlast, lonstart, lonlast, cenlon, cenlat use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, & @@ -387,12 +389,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! !----------------------------------------------------------------------- ! - integer i, ip1, j, l, ll, k, n, iret, ibdl, rc, kstart, kend + integer i, ip1, j, l, k, n, iret, ibdl, rc, kstart, kend integer ista,iend,fieldDimCount,gridDimCount,ncount_field integer jdate(8) logical foundland, foundice, found real(4) rinc(5) - real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp, dtq2001 + real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp real, dimension(:),allocatable :: ak5, bk5 real(4),dimension(:,:),pointer :: arrayr42d real(8),dimension(:,:),pointer :: arrayr82d @@ -471,7 +473,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & end do ! ! GFS does not output PD - pt = ak5(1) + pt = ak5(1) ! GFS may not have model derived radar ref. ! TKE @@ -482,7 +484,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & do j=jsta,jend do i=1,im ref_10cm(i,j,l) = SPVAL - q2(i,j,l) = SPVAL + q2(i,j,l) = SPVAL cfr(i,j,l) = SPVAL enddo enddo @@ -494,10 +496,10 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none),private(i,j),shared(jsta,jend,im,spval,qs,twbs,qwbs,ths) do j=jsta,jend do i=1,im - qs(i,j) = SPVAL + qs(i,j) = SPVAL twbs(i,j) = SPVAL qwbs(i,j) = SPVAL - ths(i,j) = SPVAL + ths(i,j) = SPVAL enddo enddo @@ -505,7 +507,6 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & dtq2 = wrt_int_state%dtp nphs = 2. dt = dtq2/nphs - dtq2001 = dtq2*0.001 ! ! GFS does not have convective cloud efficiency ! similated precip @@ -513,16 +514,22 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! 10 m humidity ! snow free albedo !$omp parallel do default(none), private(i,j), shared(jsta,jend,im,spval), & -!$omp& shared(cldefi,lspa,th10,q10,albase,cprate) +!$omp& shared(cldefi,lspa,th10,q10,albase) do j=jsta,jend do i=1,im cldefi(i,j) = SPVAL - lspa(i,j) = SPVAL - th10(i,j) = SPVAL - q10(i,j) = SPVAL + lspa(i,j) = SPVAL + th10(i,j) = SPVAL + q10(i,j) = SPVAL albase(i,j) = SPVAL + enddo + enddo - cprate(i,j) = 0.0 ! GFS does not have convective precip ???? +! GFS does not have convective precip +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,cprate) + do j=jsta,jend + do i=1,im + cprate(i,j) = 0. enddo enddo @@ -597,7 +604,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp& shared(rlwtt,rswtt,tcucn,tcucns,train) do j=jsta_2l,jend_2u do i=1,im - rlwtt(i,j,l) = spval + rlwtt(i,j,l) = spval rswtt(i,j,l) = spval tcucn(i,j,l) = spval tcucns(i,j,l) = spval @@ -713,19 +720,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find lans sea mask found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),fieldName='land',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'ibdl=',ibdl,'land, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'land',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) -!$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) + !$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) do j=jsta, jend do i=ista, iend if (arrayr42d(i,j) /= spval) sm(i,j) = 1.- arrayr42d(i,j) @@ -737,17 +744,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find ice fraction found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'ibdl=',ibdl,'ice, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) do j=jsta, jend do i=ista, iend sice(i,j) = arrayr42d(i,j) @@ -759,8 +768,9 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo get_lsmsk if (.not.foundland .or. .not.foundice) then - rc = 999 - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + rc=999 + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out endif if(mype==0) print *,'after find sm and sice,imp_physics=',imp_physics,'nbdl=',wrt_int_state%FBCount ! @@ -768,27 +778,29 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! ! get grid dimension count ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl,'idim=', & -! ista,iend,'jdim=',jsta,jend +! ista,iend,'jdim=',jsta,jend call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), grid=wrtGrid, & - fieldCount=ncount_field, name=wrtFBName,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + fieldCount=ncount_field, name=wrtFBName,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'in setvar, allocate fcstField,ibdl=',ibdl,'count=',ncount_field,'wrtFBname=',trim(wrtFBName) allocate(fcstField(ncount_field)) call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), & - fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl, 'nfield=',ncount_field - do n=1, ncount_field ! call ESMF_FieldGet(fcstField(n),typekind=typekind, name=fieldname, & - dimCount=fieldDimCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + dimCount=fieldDimCount,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (index(trim(fieldname),"vector") >0) cycle ! !** for 2D fields @@ -796,14 +808,14 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr82d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out allocate( arrayr42d(ista:iend,jsta:jend)) -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) do j=jsta, jend do i=ista, iend arrayr42d(i,j) = arrayr82d(i,j) @@ -812,58 +824,58 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! Terrain height (*G later) - if(trim(fieldname) == 'hgtsfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) + if(trim(fieldname)=='hgtsfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) do j=jsta,jend do i=ista, iend - fis(i,j) = arrayr42d(i,j) + fis(i,j)=arrayr42d(i,j) enddo enddo endif ! Surface pressure ! if(trim(fieldname)=='pressfc') then -!!$omp parallel do private(i,j) +! !$omp parallel do private(i,j) ! do j=jsta,jend ! do i=ista, iend -! pint(i,j) = arrayr42d(i,j) +! pint(i,j)=arrayr42d(i,j) ! enddo ! enddo ! endif ! PBL height using nemsio - if(trim(fieldname) == 'hpbl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) + if(trim(fieldname)=='hpbl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) do j=jsta,jend do i=ista, iend - pblh(i,j) = arrayr42d(i,j) + pblh(i,j)=arrayr42d(i,j) enddo enddo endif ! frictional velocity - if(trim(fieldname) == 'fricv') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) + if(trim(fieldname)=='fricv') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) do j=jsta,jend do i=ista, iend - ustar(i,j) = arrayr42d(i,j) + ustar(i,j)=arrayr42d(i,j) enddo enddo endif ! roughness length - if(trim(fieldname) == 'sfcr') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) + if(trim(fieldname)=='sfcr') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) do j=jsta,jend do i=ista, iend - z0(i,j) = arrayr42d(i,j) + z0(i,j)=arrayr42d(i,j) enddo enddo endif ! sfc exchange coeff - if(trim(fieldname) == 'sfexc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) + if(trim(fieldname)=='sfexc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) do j=jsta,jend do i=ista, iend sfcexc(i,j)=arrayr42d(i,j) @@ -872,18 +884,18 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! aerodynamic conductance - if(trim(fieldname) == 'acond') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) + if(trim(fieldname)=='acond') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) do j=jsta,jend do i=ista, iend - acond(i,j) = arrayr42d(i,j) + acond(i,j)=arrayr42d(i,j) enddo enddo endif ! surface potential T - if(trim(fieldname) == 'tmpsfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) + if(trim(fieldname)=='tmpsfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -894,114 +906,114 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! convective precip in m per physics time step - if(trim(fieldname) == 'cpratb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate) + if(trim(fieldname)=='cpratb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) & - avgcprate(i,j) = arrayr42d(i,j) * dtq2001 + avgcprate(i,j) = arrayr42d(i,j) * (dtq2*0.001) enddo enddo endif ! continuous bucket convective precip in m per physics time step - if(trim(fieldname) =='cprat_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate_cont) + if(trim(fieldname)=='cprat_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgcprate_cont(i,j) = arrayr42d(i,j) * dtq2001 + avgcprate_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! time averaged bucketed precip rate - if(trim(fieldname) == 'prateb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec) + if(trim(fieldname)=='prateb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec(i,j) = arrayr42d(i,j) * dtq2001 + avgprec(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! time averaged continuous precip rate in m per physics time step - if(trim(fieldname) == 'prate_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec_cont) + if(trim(fieldname)=='prate_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec_cont(i,j) = arrayr42d(i,j) * dtq2001 + avgprec_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! precip rate in m per physics time step - if(trim(fieldname) == 'tprcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,prec) + if(trim(fieldname)=='tprcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,prec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - prec(i,j) = arrayr42d(i,j) * (dtq2001 * 1000./dtp) + prec(i,j) = arrayr42d(i,j) * (dtq2*0.001) * 1000./dtp endif enddo enddo endif ! convective precip rate in m per physics time step - if(trim(fieldname) == 'cnvprcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,cprate) + if(trim(fieldname)=='cnvprcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,cprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2001 * 1000./dtp) + cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2*0.001) * 1000./dtp endif enddo enddo endif ! inst snow water eqivalent - if(trim(fieldname) == 'weasd') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) + if(trim(fieldname)=='weasd') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend sno(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) sno(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j)==0.)sno(i,j) = spval enddo enddo endif ! ave snow cover - if(trim(fieldname) == 'snowc_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) + if(trim(fieldname)=='snowc_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend snoavg(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) snoavg(i,j) = spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j) = spval if (snoavg(i,j) /= spval) snoavg(i,j) = snoavg(i,j)/100. enddo enddo endif ! snow depth in mm - if(trim(fieldname) == 'snod') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) + if(trim(fieldname)=='snod') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend si(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) si(i,j)=spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 enddo enddo endif ! 2m potential T (computed later) - if(trim(fieldname) == 'tmp2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) + if(trim(fieldname)=='tmp2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) do j=jsta,jend do i=ista, iend tshltr(i,j) = arrayr42d(i,j) @@ -1010,8 +1022,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! surface potential T - if(trim(fieldname) == 'spfh2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) + if(trim(fieldname)=='spfh2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) do j=jsta,jend do i=ista, iend qshltr(i,j) = arrayr42d(i,j) @@ -1020,8 +1032,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! mid day avg albedo in fraction - if(trim(fieldname) == 'albdo_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) + if(trim(fieldname)=='albdo_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) do j=jsta,jend do i=ista, iend avgalbedo(i,j) = arrayr42d(i,j) @@ -1033,8 +1045,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname) == 'tcdc_aveclm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) + if(trim(fieldname)=='tcdc_aveclm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) do j=jsta,jend do i=ista, iend avgtcdc(i,j) = arrayr42d(i,j) @@ -1046,8 +1058,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! maximum snow albedo in fraction - if(trim(fieldname) == 'snoalb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) + if(trim(fieldname)=='snoalb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) do j=jsta,jend do i=ista, iend mxsnal(i,j) = arrayr42d(i,j) @@ -1059,8 +1071,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave high cloud fraction - if(trim(fieldname) == 'tcdc_avehcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) + if(trim(fieldname)=='tcdc_avehcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) do j=jsta,jend do i=ista, iend avgcfrach(i,j) = arrayr42d(i,j) @@ -1072,8 +1084,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave low cloud fraction - if(trim(fieldname) == 'tcdc_avelcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) + if(trim(fieldname)=='tcdc_avelcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracl(i,j) = arrayr42d(i,j) @@ -1085,8 +1097,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave middle cloud fraction - if(trim(fieldname) == 'tcdc_avemcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) + if(trim(fieldname)=='tcdc_avemcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracm(i,j) = arrayr42d(i,j) @@ -1098,8 +1110,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst convective cloud fraction - if(trim(fieldname) == 'tcdccnvcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) + if(trim(fieldname)=='tcdccnvcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) do j=jsta,jend do i=ista, iend cnvcfr(i,j) = arrayr42d(i,j) @@ -1111,8 +1123,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! slope type - if(trim(fieldname) == 'sltyp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) + if(trim(fieldname)=='sltyp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1125,8 +1137,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname) == 'cnwat') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) + if(trim(fieldname)=='cnwat') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) do j=jsta,jend do i=ista, iend cmc(i,j) = arrayr42d(i,j) @@ -1137,8 +1149,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! frozen precip fraction - if(trim(fieldname) == 'cpofp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) + if(trim(fieldname)=='cpofp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -1152,8 +1164,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sea ice skin temperature - if(trim(fieldname) == 'tisfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) + if(trim(fieldname)=='tisfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) do j=jsta,jend do i=ista,iend if (arrayr42d(i,j) /= spval) then @@ -1167,8 +1179,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation fraction - if(trim(fieldname) == 'veg') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) + if(trim(fieldname)=='veg') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) do j=jsta,jend do i=ista, iend vegfrc(i,j) = arrayr42d(i,j) @@ -1183,8 +1195,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,1) = arrayr42d(i,j) @@ -1194,8 +1206,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,2) = arrayr42d(i,j) @@ -1205,8 +1217,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,3) = arrayr42d(i,j) @@ -1216,8 +1228,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,4) = arrayr42d(i,j) @@ -1227,8 +1239,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,1) = arrayr42d(i,j) @@ -1238,8 +1250,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,2) = arrayr42d(i,j) @@ -1249,8 +1261,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,3) = arrayr42d(i,j) @@ -1260,8 +1272,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,4) = arrayr42d(i,j) @@ -1271,8 +1283,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,1) = arrayr42d(i,j) @@ -1283,8 +1295,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,2) = arrayr42d(i,j) @@ -1295,8 +1307,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,3) = arrayr42d(i,j) @@ -1307,8 +1319,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,4) = arrayr42d(i,j) @@ -1320,7 +1332,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged incoming sfc longwave if(trim(fieldname)=='dlwrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) do j=jsta,jend do i=ista, iend alwin(i,j) = arrayr42d(i,j) @@ -1329,8 +1341,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc longwave - if(trim(fieldname) == 'dlwrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) + if(trim(fieldname)=='dlwrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) do j=jsta,jend do i=ista, iend rlwin(i,j) = arrayr42d(i,j) @@ -1339,8 +1351,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc longwave, CLDRAD puts a minus sign - if(trim(fieldname) == 'ulwrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) + if(trim(fieldname)=='ulwrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) do j=jsta,jend do i=ista, iend alwout(i,j) = arrayr42d(i,j) @@ -1350,8 +1362,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc longwave - if(trim(fieldname) == 'ulwrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) + if(trim(fieldname)=='ulwrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) do j=jsta,jend do i=ista, iend radot(i,j) = arrayr42d(i,j) @@ -1360,8 +1372,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing model top longwave - if(trim(fieldname) == 'ulwrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) + if(trim(fieldname)=='ulwrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) do j=jsta,jend do i=ista, iend alwtoa(i,j) = arrayr42d(i,j) @@ -1370,8 +1382,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc shortwave - if(trim(fieldname) == 'dswrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) + if(trim(fieldname)=='dswrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) do j=jsta,jend do i=ista, iend aswin(i,j) = arrayr42d(i,j) @@ -1380,8 +1392,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc shortwave - if(trim(fieldname) == 'dswrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) + if(trim(fieldname)=='dswrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) do j=jsta,jend do i=ista, iend rswin(i,j) = arrayr42d(i,j) @@ -1390,8 +1402,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc uv-b - if(trim(fieldname) == 'duvb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) + if(trim(fieldname)=='duvb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) do j=jsta,jend do i=ista, iend auvbin(i,j) = arrayr42d(i,j) @@ -1400,8 +1412,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc clear sky uv-b - if(trim(fieldname) == 'cduvb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) + if(trim(fieldname)=='cduvb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) do j=jsta,jend do i=ista, iend auvbinc(i,j) = arrayr42d(i,j) @@ -1410,8 +1422,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc shortwave,CLDRAD puts a minus sign - if(trim(fieldname) == 'uswrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) + if(trim(fieldname)=='uswrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) do j=jsta,jend do i=ista, iend aswout(i,j) = arrayr42d(i,j) @@ -1421,8 +1433,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc shortwave - if(trim(fieldname) == 'uswrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) + if(trim(fieldname)=='uswrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) do j=jsta,jend do i=ista, iend rswout(i,j) = arrayr42d(i,j) @@ -1431,8 +1443,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged model top incoming shortwave - if(trim(fieldname) == 'dswrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) + if(trim(fieldname)=='dswrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) do j=jsta,jend do i=ista, iend aswintoa(i,j) = arrayr42d(i,j) @@ -1441,8 +1453,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ime averaged model top outgoing shortwave - if(trim(fieldname) == 'uswrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) + if(trim(fieldname)=='uswrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) do j=jsta,jend do i=ista, iend aswtoa(i,j) = arrayr42d(i,j) @@ -1452,8 +1464,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface sensible heat flux, multiplied by -1 because ! wrf model fluxhas reversed sign convention using gfsio - if(trim(fieldname) == 'shtfl_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) + if(trim(fieldname)=='shtfl_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) do j=jsta,jend do i=ista, iend sfcshx(i,j) = arrayr42d(i,j) @@ -1463,8 +1475,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface sensible heat flux - if(trim(fieldname) == 'shtfl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) + if(trim(fieldname)=='shtfl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) do j=jsta,jend do i=ista, iend twbs(i,j) = arrayr42d(i,j) @@ -1475,8 +1487,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface latent heat flux, multiplied by -1 because ! wrf model flux has reversed sign vonvention using gfsio - if(trim(fieldname) == 'lhtfl_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) + if(trim(fieldname)=='lhtfl_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) do j=jsta,jend do i=ista, iend sfclhx(i,j) = arrayr42d(i,j) @@ -1486,8 +1498,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface latent heat flux - if(trim(fieldname) == 'lhtfl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) + if(trim(fieldname)=='lhtfl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) do j=jsta,jend do i=ista, iend qwbs(i,j) = arrayr42d(i,j) @@ -1497,30 +1509,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged ground heat flux - if(trim(fieldname) == 'gflux_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) + if(trim(fieldname)=='gflux_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend subshx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) subshx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval enddo enddo endif ! inst ground heat flux - if(trim(fieldname) == 'gflux') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) + if(trim(fieldname)=='gflux') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend grnflx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) grnflx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval enddo enddo endif ! time averaged zonal momentum flux - if(trim(fieldname) == 'uflx_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) + if(trim(fieldname)=='uflx_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) do j=jsta,jend do i=ista, iend sfcux(i,j) = arrayr42d(i,j) @@ -1529,8 +1541,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional momentum flux - if(trim(fieldname) == 'vflx_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) + if(trim(fieldname)=='vflx_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) do j=jsta,jend do i=ista, iend sfcvx(i,j) = arrayr42d(i,j) @@ -1539,8 +1551,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged zonal gravity wave stress - if(trim(fieldname) == 'u-gwd_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) + if(trim(fieldname)=='u-gwd_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) do j=jsta,jend do i=ista, iend gtaux(i,j) = arrayr42d(i,j) @@ -1549,8 +1561,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional gravity wave stress - if(trim(fieldname) == 'v-gwd_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) + if(trim(fieldname)=='v-gwd_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) do j=jsta,jend do i=ista, iend gtauy(i,j) = arrayr42d(i,j) @@ -1559,30 +1571,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged accumulated potential evaporation - if(trim(fieldname) == 'pevpr_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) + if(trim(fieldname)=='pevpr_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgpotevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgpotevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval enddo enddo endif ! inst potential evaporation - if(trim(fieldname) == 'pevpr') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) + if(trim(fieldname)=='pevpr') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend potevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) potevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval enddo enddo endif ! 10 m u - if(trim(fieldname) == 'ugrd10m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) + if(trim(fieldname)=='ugrd10m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) do j=jsta,jend do i=ista, iend u10(i,j) = arrayr42d(i,j) @@ -1592,8 +1604,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! 10 m v - if(trim(fieldname) == 'vgrd10m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) + if(trim(fieldname)=='vgrd10m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) do j=jsta,jend do i=ista, iend v10(i,j) = arrayr42d(i,j) @@ -1603,8 +1615,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation type - if(trim(fieldname) == 'vtype') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) + if(trim(fieldname)=='vtype') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1617,8 +1629,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil type - if(trim(fieldname) == 'sotyp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) + if(trim(fieldname)=='sotyp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1631,8 +1643,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud top pressure - if(trim(fieldname) == 'prescnvclt') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) + if(trim(fieldname)=='prescnvclt') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) do j=jsta,jend do i=ista, iend ptop(i,j) = arrayr42d(i,j) @@ -1642,8 +1654,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud bottom pressure - if(trim(fieldname) == 'prescnvclb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) + if(trim(fieldname)=='prescnvclb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) do j=jsta,jend do i=ista, iend pbot(i,j) = arrayr42d(i,j) @@ -1653,8 +1665,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top pressure - if(trim(fieldname) == 'pres_avelct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) + if(trim(fieldname)=='pres_avelct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) do j=jsta,jend do i=ista, iend ptopl(i,j) = arrayr42d(i,j) @@ -1663,8 +1675,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud bottom pressure - if(trim(fieldname) == 'pres_avelcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) + if(trim(fieldname)=='pres_avelcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) do j=jsta,jend do i=ista, iend pbotl(i,j) = arrayr42d(i,j) @@ -1673,8 +1685,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top temperature - if(trim(fieldname) == 'tmp_avelct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) + if(trim(fieldname)=='tmp_avelct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) do j=jsta,jend do i=ista, iend ttopl(i,j) = arrayr42d(i,j) @@ -1683,8 +1695,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top pressure - if(trim(fieldname) == 'pres_avemct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) + if(trim(fieldname)=='pres_avemct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) do j=jsta,jend do i=ista, iend ptopm(i,j) = arrayr42d(i,j) @@ -1693,8 +1705,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud bottom pressure - if(trim(fieldname) == 'pres_avemcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) + if(trim(fieldname)=='pres_avemcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) do j=jsta,jend do i=ista, iend pbotm(i,j) = arrayr42d(i,j) @@ -1703,8 +1715,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top temperature - if(trim(fieldname) == 'tmp_avemct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) + if(trim(fieldname)=='tmp_avemct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) do j=jsta,jend do i=ista, iend ttopm(i,j) = arrayr42d(i,j) @@ -1713,8 +1725,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top pressure - if(trim(fieldname) == 'pres_avehct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) + if(trim(fieldname)=='pres_avehct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) do j=jsta,jend do i=ista, iend ptoph(i,j) = arrayr42d(i,j) @@ -1723,8 +1735,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud bottom pressure - if(trim(fieldname) == 'pres_avehcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) + if(trim(fieldname)=='pres_avehcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) do j=jsta,jend do i=ista, iend pboth(i,j) = arrayr42d(i,j) @@ -1733,8 +1745,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top temperature - if(trim(fieldname) == 'tmp_avehct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) + if(trim(fieldname)=='tmp_avehct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) do j=jsta,jend do i=ista, iend ttoph(i,j) = arrayr42d(i,j) @@ -1743,8 +1755,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged boundary layer cloud cover - if(trim(fieldname) == 'tcdc_avebndcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) + if(trim(fieldname)=='tcdc_avebndcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) do j=jsta,jend do i=ista, iend pblcfr(i,j) = arrayr42d(i,j) @@ -1754,8 +1766,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! cloud work function - if(trim(fieldname) == 'cwork_aveclm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) + if(trim(fieldname)=='cwork_aveclm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) do j=jsta,jend do i=ista, iend cldwork(i,j) = arrayr42d(i,j) @@ -1764,8 +1776,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! water runoff - if(trim(fieldname) == 'watr_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) + if(trim(fieldname)=='watr_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) do j=jsta,jend do i=ista, iend runoff(i,j) = arrayr42d(i,j) @@ -1775,8 +1787,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max temperature - if(trim(fieldname) == 'tmax_max2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) + if(trim(fieldname)=='tmax_max2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxtshltr(i,j) = arrayr42d(i,j) @@ -1785,8 +1797,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname) == 'tmin_min2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) + if(trim(fieldname)=='tmin_min2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) do j=jsta,jend do i=ista, iend mintshltr(i,j) = arrayr42d(i,j) @@ -1795,8 +1807,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ice thickness - if(trim(fieldname) == 'icetk') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) + if(trim(fieldname)=='icetk') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) do j=jsta,jend do i=ista, iend dzice(i,j) = arrayr42d(i,j) @@ -1805,8 +1817,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! wilting point - if(trim(fieldname) == 'wilt') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) + if(trim(fieldname)=='wilt') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) do j=jsta,jend do i=ista, iend smcwlt(i,j) = arrayr42d(i,j) @@ -1816,8 +1828,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sunshine duration - if(trim(fieldname) == 'sunsd_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) + if(trim(fieldname)=='sunsd_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) do j=jsta,jend do i=ista, iend suntime(i,j) = arrayr42d(i,j) @@ -1826,8 +1838,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! field capacity - if(trim(fieldname) == 'fldcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) + if(trim(fieldname)=='fldcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) do j=jsta,jend do i=ista, iend fieldcapa(i,j) = arrayr42d(i,j) @@ -1837,8 +1849,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible beam downward solar flux - if(trim(fieldname) == 'vbdsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) + if(trim(fieldname)=='vbdsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend avisbeamswin(i,j) = arrayr42d(i,j) @@ -1847,8 +1859,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible diffuse downward solar flux - if(trim(fieldname) == 'vddsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) + if(trim(fieldname)=='vddsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend avisdiffswin(i,j) = arrayr42d(i,j) @@ -1857,8 +1869,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR beam downward solar flux - if(trim(fieldname) == 'nbdsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) + if(trim(fieldname)=='nbdsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend airbeamswin(i,j) = arrayr42d(i,j) @@ -1867,8 +1879,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR diffuse downward solar flux - if(trim(fieldname) == 'nddsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) + if(trim(fieldname)=='nddsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend airdiffswin(i,j) = arrayr42d(i,j) @@ -1877,8 +1889,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing LW - if(trim(fieldname) == 'csulf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) + if(trim(fieldname)=='csulf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) do j=jsta,jend do i=ista, iend alwoutc(i,j) = arrayr42d(i,j) @@ -1887,8 +1899,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing LW - if(trim(fieldname) == 'csulftoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) + if(trim(fieldname)=='csulftoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) do j=jsta,jend do i=ista, iend alwtoac(i,j) = arrayr42d(i,j) @@ -1897,8 +1909,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing SW - if(trim(fieldname) == 'csusf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) + if(trim(fieldname)=='csusf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) do j=jsta,jend do i=ista, iend aswoutc(i,j) = arrayr42d(i,j) @@ -1907,8 +1919,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing SW - if(trim(fieldname) == 'csusftoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) + if(trim(fieldname)=='csusftoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) do j=jsta,jend do i=ista, iend aswtoac(i,j) = arrayr42d(i,j) @@ -1917,8 +1929,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming LW - if(trim(fieldname) == 'csdlf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) + if(trim(fieldname)=='csdlf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) do j=jsta,jend do i=ista, iend alwinc(i,j) = arrayr42d(i,j) @@ -1927,8 +1939,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming SW - if(trim(fieldname) == 'csdsf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) + if(trim(fieldname)=='csdsf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) do j=jsta,jend do i=ista, iend aswinc(i,j) = arrayr42d(i,j) @@ -1937,8 +1949,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max specific humidity - if(trim(fieldname) == 'spfhmax_max2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) + if(trim(fieldname)=='spfhmax_max2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxqshltr(i,j) = arrayr42d(i,j) @@ -1947,8 +1959,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname) == 'spfhmin_min2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) + if(trim(fieldname)=='spfhmin_min2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) do j=jsta,jend do i=ista, iend minqshltr(i,j) = arrayr42d(i,j) @@ -1957,8 +1969,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! storm runoffs - if(trim(fieldname) == 'ssrun_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) + if(trim(fieldname)=='ssrun_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) do j=jsta,jend do i=ista, iend ssroff(i,j) = arrayr42d(i,j) @@ -1968,8 +1980,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! direct soil evaporation - if(trim(fieldname) == 'evbs_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) + if(trim(fieldname)=='evbs_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgedir(i,j) = arrayr42d(i,j) @@ -1979,8 +1991,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! canopy water evap - if(trim(fieldname) == 'evcw_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) + if(trim(fieldname)=='evcw_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgecan(i,j) = arrayr42d(i,j) @@ -1990,8 +2002,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! plant transpiration - if(trim(fieldname) == 'trans_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) + if(trim(fieldname)=='trans_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgetrans(i,j) = arrayr42d(i,j) @@ -2001,19 +2013,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow sublimation - if(trim(fieldname) == 'sbsno_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) + if(trim(fieldname)=='sbsno_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgesnow(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgesnow(i,j) = spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval enddo enddo endif ! total soil moisture - if(trim(fieldname) == 'soilm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) + if(trim(fieldname)=='soilm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) do j=jsta,jend do i=ista, iend smstot(i,j) = arrayr42d(i,j) @@ -2023,8 +2035,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow phase change heat flux - if(trim(fieldname) == 'snohf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) + if(trim(fieldname)=='snohf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) do j=jsta,jend do i=ista, iend snopcx(i,j) = arrayr42d(i,j) @@ -2034,17 +2046,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! else if (fieldDimCount > gridDimCount) then - else if (fieldDimCount == 3) then + else if (fieldDimCount ==3) then if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr43d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr83d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out allocate(arrayr43d(ista:iend,jsta:jend,kstart:kend)) arrayr43d = 0. do k=kstart,kend -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) do j=jsta,jend do i=ista,iend arrayr43d(i,j,k) = arrayr83d(i,j,k) @@ -2054,8 +2068,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level T - if(trim(fieldname) == 'tmp') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) + if(trim(fieldname)=='tmp') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend @@ -2065,7 +2079,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo !! sig4 -!$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) + !$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) do j=jsta,jend do i=ista, iend tlmh = t(i,j,lm) * t(i,j,lm) @@ -2075,237 +2089,172 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level spfh - if(trim(fieldname) == 'spfh') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) + if(trim(fieldname)=='spfh') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q(i,j,l) = arrayr43d(i,j,l) + q(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level u wind - if(trim(fieldname) == 'ugrd') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) + if(trim(fieldname)=='ugrd') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - uh(i,j,l) = arrayr43d(i,j,l) + uh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level v wind - if(trim(fieldname) == 'vgrd') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) + if(trim(fieldname)=='vgrd') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - vh(i,j,l) = arrayr43d(i,j,l) + vh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level pressure thinkness - if(trim(fieldname) == 'dpres') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) + if(trim(fieldname)=='dpres') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - dpres(i,j,l) = arrayr43d(i,j,l) + dpres(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level gh thinkness, model output negative delz - if(trim(fieldname) == 'delz') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) + if(trim(fieldname)=='delz') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - zint(i,j,l) = -arrayr43d(i,j,l) + zint(i,j,l)=-1.*arrayr43d(i,j,l) enddo enddo enddo endif ! model level w - if(trim(fieldname) == 'dzdt') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) + if(trim(fieldname)=='dzdt') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - wh(i,j,l) = arrayr43d(i,j,l) + wh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ozone mixing ratio - if(trim(fieldname) == 'o3mr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) + if(trim(fieldname)=='o3mr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - o3(i,j,l) = arrayr43d(i,j,l) + o3(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif -! for GFDL or MG3 MP -! ------------------ - if (imp_physics == 10 .or. imp_physics == 11) then +! for GFDL MP + if (imp_physics == 11) then ! model level cloud water mixing ratio - if(trim(fieldname) == 'clwmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) + if(trim(fieldname)=='clwmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqw(i,j,l) = arrayr43d(i,j,l) + qqw(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ice mixing ratio - if(trim(fieldname) == 'icmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) + if(trim(fieldname)=='icmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqi(i,j,l) = arrayr43d(i,j,l) + qqi(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname) == 'rwmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) + if(trim(fieldname)=='rwmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqr(i,j,l) = arrayr43d(i,j,l) + qqr(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level snow mixing ratio - if(trim(fieldname) == 'snmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) + if(trim(fieldname)=='snmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqs(i,j,l) = arrayr43d(i,j,l) + qqs(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname) == 'grle') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqg(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - endif !gfdlmp or MG3 mp -! for MG3 MP -! ---------- - if (imp_physics == 10) then - ! model level cloud water mixing ratio number concentration - if(trim(fieldname) == 'clwnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnw,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqnw(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level ice mixing ratio number concentration - if(trim(fieldname) == 'icenc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqni,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqni(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level rain water mixing ratio number concentration - if(trim(fieldname) == 'rwnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnr,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqnr(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level snow mixing ratio number concentration - if(trim(fieldname) == 'snnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqns,arrayr43d) + if(trim(fieldname)=='grle') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqns(i,j,l) = arrayr43d(i,j,l) + qqg(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif - - ! model level rain water mixing ratio number concentration - if(trim(fieldname) == 'grlenc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqng,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqng(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - endif ! for MG3 MP +!gfdlmp + endif ! model level cloud amount - if(trim(fieldname) == 'cld_amt') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) + if(trim(fieldname)=='cld_amt') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - cfr(i,j,l) = arrayr43d(i,j,l) + cfr(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ref3d - if(trim(fieldname) == 'ref3D') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) + if(trim(fieldname)=='ref3D') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - ref_10cm(i,j,l) = arrayr43d(i,j,l) + ref_10cm(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo @@ -2313,12 +2262,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level ref3d - if(trim(fieldname) == 'tke') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) + if(trim(fieldname)=='tke') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q2(i,j,l) = arrayr43d(i,j,l) + q2(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo @@ -2326,7 +2275,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !3d fields endif - enddo ! end loop ncount_field +! end loop ncount_field + enddo if ( index(trim(wrt_int_state%wrtFB_names(ibdl)),trim(filename_base(1))) > 0) & setvar_atmfile = .true. @@ -2352,33 +2302,46 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,omga,wh,dpres,zint) do j=jsta,jend do i=1,im - omga(i,j,l) = - wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) + omga(i,j,l) = (-1.) * wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) zint(i,j,l) = zint(i,j,l) + zint(i,j,l+1) enddo enddo enddo ! compute pint from top down -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint,pd,spval) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint) do j=jsta,jend do i=1,im pint(i,j,1) = ak5(1) - pd(i,j) = spval - enddo - enddo + end do + end do do l=2,lp1 - ll = l - 1 -!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,pint,dpres,pmid) +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pint,dpres) do j=jsta,jend do i=1,im - pint(i,j,l) = pint(i,j,ll) + dpres(i,j,ll) + pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) + enddo + enddo + end do + !compute pmid from averaged two layer pint - pmid(i,j,ll) = 0.5*(pint(i,j,ll)+pint(i,j,l)) + do l=lm,1,-1 +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pmid,pint) + do j=jsta,jend + do i=1,im + pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) enddo enddo enddo +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,spval,pt,pd,pint) + do j=jsta,jend + do i=1,im + pd(i,j) = spval + pint(i,j,1) = pt + end do + end do ! print *,'in setvar, pt=',pt,'ak5(lp1)=', ak5(lp1),'ak5(1)=',ak5(1) ! compute alpint @@ -2386,23 +2349,22 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,alpint,pint) do j=jsta,jend do i=1,im - alpint(i,j,l) = log(pint(i,j,l)) - enddo - enddo - enddo + alpint(i,j,l)=log(pint(i,j,l)) + end do + end do + end do ! compute zmid do l=lm,1,-1 - ll = l + 1 -!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,zmid,zint,pmid,alpint) +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,zmid,zint,pmid,alpint) do j=jsta,jend do i=1,im - zmid(i,j,l) = zint(i,j,ll) + (zint(i,j,l)-zint(i,j,ll)) & - * (log(pmid(i,j,l))-alpint(i,j,ll)) & - / (alpint(i,j,l)-alpint(i,j,ll)) - enddo - enddo - enddo + zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & + (log(pmid(i,j,l))-alpint(i,j,l+1))/ & + (alpint(i,j,l)-alpint(i,j,l+1)) + end do + end do + end do ! print *,'in post_gfs,zmid=',maxval(zmid(1:im,jsta:jend,1)), & ! minval(zmid(1:im,jsta:jend,1)),maxloc(zmid(1:im,jsta:jend,1)), & ! 'zint=',maxval(zint(1:im,jsta:jend,2)),minval(zint(1:im,jsta:jend,1)), & @@ -2428,13 +2390,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo enddo -! compute cwm for gfdlmp or MG3 - if( imp_physics == 10 .or. imp_physics == 11) then +! compute cwm for gfdlmp + if( imp_physics == 11 ) then do l=1,lm !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,ista,iend,cwm,qqg,qqs,qqr,qqi,qqw) do j=jsta,jend do i=ista,iend - cwm(i,j,l) = qqg(i,j,l) + qqs(i,j,l) + qqr(i,j,l) + qqi(i,j,l) + qqw(i,j,l) + cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) enddo enddo enddo @@ -2444,8 +2406,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,lm,pshltr,pint,tshltr) do j=jsta,jend do i=ista, iend - pshltr(I,J) = pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j) = tshltr(i,j)*(p1000/pshltr(I,J))**CAPA + pshltr(I,J)=pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) + tshltr(i,j)= tshltr(i,j)*(p1000/pshltr(I,J))**CAPA enddo enddo @@ -2456,13 +2418,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if(ptop(i,j) < spval)then do l=1,lm if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l + htop(i,j)=l exit - endif - enddo - endif - enddo - enddo + end if + end do + end if + end do + end do ! hbot do j=jsta,jend From 9c98799acf4a20d6ac73ce030af0c3e8e533f4ed Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 5 Sep 2020 01:23:20 +0000 Subject: [PATCH 85/91] updating FV3GFS_io.F90 to retain original code for cold start --- io/FV3GFS_io.F90 | 57 ++++++++++++++++++++++++++++++------------------ 1 file changed, 36 insertions(+), 21 deletions(-) diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 472f941ea..329eac5ec 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1357,32 +1357,47 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo else + if (Model%kdt <= 0) then !$omp parallel do default(shared) private(nb, ix, tem) - do nb = 1, Atm_block%nblks - do ix = 1, Atm_block%blksz(nb) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) !--- specify tsfcl/zorll/zorli from existing variable tsfco/zorlo -! Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) -! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) -! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) -! Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) - Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) - if (Sfcprop(nb)%slmsk(ix) == 1) then - Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) - Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) - else - tem = one - Sfcprop(nb)%fice(ix) - Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & - + Sfcprop(nb)%zorlo(ix) * tem - - if (Sfcprop(nb)%fice(ix) > min(Model%min_seaice,Model%min_lakeice)) then +! Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) +! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) + if (Sfcprop(nb)%slmsk(ix) == 1) then + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + else + tem = one - Sfcprop(nb)%fice(ix) + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%zorlo(ix) * tem + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%tsfco(ix) * tem endif - -! Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & -! + Sfcprop(nb)%tsfco(ix) * tem - endif + enddo enddo - enddo + else +!$omp parallel do default(shared) private(nb, ix, tem) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + !--- specify tsfcl/zorll/zorli from existing variable tsfco/zorlo + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) + if (Sfcprop(nb)%slmsk(ix) == 1) then + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + else + tem = one - Sfcprop(nb)%fice(ix) + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%zorlo(ix) * tem + if (Sfcprop(nb)%fice(ix) > min(Model%min_seaice,Model%min_lakeice)) then + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + endif + endif + enddo + enddo + endif endif ! if (Model%frac_grid) !#ifdef CCPP From 5a483852bccd4542f7fce6ccb262d6012fb7a263 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 6 Sep 2020 00:24:15 +0000 Subject: [PATCH 86/91] copy of branch SM_Sep022020 with my version of post_gfs.F90 --- io/post_gfs.F90 | 922 +++++++++++++++++++++++++----------------------- 1 file changed, 480 insertions(+), 442 deletions(-) diff --git a/io/post_gfs.F90 b/io/post_gfs.F90 index 76dd0251c..248ce6d06 100644 --- a/io/post_gfs.F90 +++ b/io/post_gfs.F90 @@ -112,19 +112,20 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & !----------------------------------------------------------------------- ! ! if(mype==0) print *,'in post_run,be post_alctvars, dim=',wrt_int_state%im, & -! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & -! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & +! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & +! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & ! 'jstagrp=',jstagrp,'jendgrp=',jendgrp - call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & - wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & - mpicomp,jts,jte,jstagrp,jendgrp) + + call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & + wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & + mpicomp,jts,jte,jstagrp,jendgrp) ! !----------------------------------------------------------------------- !*** read namelist for pv,th,po !----------------------------------------------------------------------- ! - log_postalct = .true. - first_grbtbl = .true. + log_postalct = .true. + first_grbtbl = .true. read_postcntrl = .true. ! ENDIF @@ -137,16 +138,16 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & ifmin = mynfmin if (ifhr == 0 ) ifmin = 0 if(mype==0) print *,'bf set_postvars,ifmin=',ifmin,'ifhr=',ifhr - setvar_atmfile=.false. - setvar_sfcfile=.false. + setvar_atmfile = .false. + setvar_sfcfile = .false. call set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & - setvar_sfcfile) + setvar_sfcfile) ! print *,'af set_postvars,setvar_atmfile=',setvar_atmfile, & ! 'setvar_sfcfile=',setvar_sfcfile ! if (setvar_atmfile.and.setvar_sfcfile) then -! 20190807 no need to call microinit for GFDLMP +! 20190807 need to call microinit only for Ferrier microphysics ! call MICROINIT ! if(grib=="grib2" .and. read_postcntrl) then @@ -239,66 +240,62 @@ subroutine post_getattr_gfs(wrt_int_state, fldbundle) ! look at the field bundle attributes call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, Count=attcount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__,file=__FILE__))return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return ! aklen=0. do i=1, attCount - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & - typekind=typekind, itemCount=n, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__,file=__FILE__))return ! bail out + call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & + attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & + typekind=typekind, itemCount=n, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return if (typekind==ESMF_TYPEKIND_I4 ) then - if(n==1) then + if(n == 1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, rc=rc) - if (trim(attName) == 'ncnsto') wrt_int_state%ntrac=varival - if (trim(attName) == 'ncld') wrt_int_state%ncld=varival - if (trim(attName) == 'nsoil') wrt_int_state%nsoil=varival - if (trim(attName) == 'fhzero') wrt_int_state%fhzero=varival - if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics=varival + name=trim(attName), value=varival, rc=rc) + if (trim(attName) == 'ncnsto') wrt_int_state%ntrac = varival + if (trim(attName) == 'ncld') wrt_int_state%ncld = varival + if (trim(attName) == 'nsoil') wrt_int_state%nsoil = varival + if (trim(attName) == 'fhzero') wrt_int_state%fhzero = varival + if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics = varival endif - else if (typekind==ESMF_TYPEKIND_R4) then - if(n==1) then + else if (typekind == ESMF_TYPEKIND_R4) then + if(n == 1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr4val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + name=trim(attName), value=varr4val, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr4val endif - else if(n>1) then + else if(n > 1) then if(trim(attName) =="ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 - else if(trim(attName) =="bk") then + else if(trim(attName) == "bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) allocate(wrt_int_state%bk(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%bk, rc=rc) + name=trim(attName), valueList=wrt_int_state%bk, rc=rc) endif endif - else if (typekind==ESMF_TYPEKIND_R8) then - if(n==1) then + else if (typekind == ESMF_TYPEKIND_R8) then + if(n == 1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & name=trim(attName), value=varr8val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr8val endif - else if(n>1) then - if(trim(attName) =="ak") then + else if(n > 1) then + if(trim(attName) == "ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 else if(trim(attName) =="bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) @@ -332,7 +329,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use vrbls3d, only: t, q, uh, vh, wh, alpint, dpres, zint, zmid, o3, & qqr, qqs, cwm, qqi, qqw, qqg, omga, cfr, pmid, & q2, rlwtt, rswtt, tcucn, tcucns, train, el_pbl, & - pint, exch_h, ref_10cm + pint, exch_h, ref_10cm, & + qqnw, qqni, qqnr, qqns, qqng use vrbls2d, only: f, pd, sigt4, fis, pblh, ustar, z0, ths, qs, twbs,& qwbs, avgcprate, cprate, avgprec, prec, lspa, sno,& cldefi, th10, q10, tshltr, pshltr, tshltr, albase,& @@ -360,11 +358,11 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use soil, only: sldpth, sh2o, smc, stc use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice use ctlblk_mod, only: im, jm, lm, lp1, jsta, jend, jsta_2l, jend_2u, jsta_m,jend_m, & - lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & - tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & + lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & + tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & ardlw, ardsw, asrfc, avrain, avcnvc, iSF_SURFACE_PHYSICS,& - td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & - alsl, spl, ihrst + td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & + alsl, spl, ihrst use params_mod, only: erad, dtr, capa, p1000 use gridspec_mod,only: latstart, latlast, lonstart, lonlast, cenlon, cenlat use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, & @@ -389,12 +387,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! !----------------------------------------------------------------------- ! - integer i, ip1, j, l, k, n, iret, ibdl, rc, kstart, kend + integer i, ip1, j, l, ll, k, n, iret, ibdl, rc, kstart, kend integer ista,iend,fieldDimCount,gridDimCount,ncount_field integer jdate(8) logical foundland, foundice, found real(4) rinc(5) - real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp + real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp, dtq2001 real, dimension(:),allocatable :: ak5, bk5 real(4),dimension(:,:),pointer :: arrayr42d real(8),dimension(:,:),pointer :: arrayr82d @@ -473,7 +471,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & end do ! ! GFS does not output PD - pt = ak5(1) + pt = ak5(1) ! GFS may not have model derived radar ref. ! TKE @@ -484,7 +482,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & do j=jsta,jend do i=1,im ref_10cm(i,j,l) = SPVAL - q2(i,j,l) = SPVAL + q2(i,j,l) = SPVAL cfr(i,j,l) = SPVAL enddo enddo @@ -496,10 +494,10 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none),private(i,j),shared(jsta,jend,im,spval,qs,twbs,qwbs,ths) do j=jsta,jend do i=1,im - qs(i,j) = SPVAL + qs(i,j) = SPVAL twbs(i,j) = SPVAL qwbs(i,j) = SPVAL - ths(i,j) = SPVAL + ths(i,j) = SPVAL enddo enddo @@ -507,6 +505,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & dtq2 = wrt_int_state%dtp nphs = 2. dt = dtq2/nphs + dtq2001 = dtq2*0.001 ! ! GFS does not have convective cloud efficiency ! similated precip @@ -514,22 +513,16 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! 10 m humidity ! snow free albedo !$omp parallel do default(none), private(i,j), shared(jsta,jend,im,spval), & -!$omp& shared(cldefi,lspa,th10,q10,albase) +!$omp& shared(cldefi,lspa,th10,q10,albase,cprate) do j=jsta,jend do i=1,im cldefi(i,j) = SPVAL - lspa(i,j) = SPVAL - th10(i,j) = SPVAL - q10(i,j) = SPVAL + lspa(i,j) = SPVAL + th10(i,j) = SPVAL + q10(i,j) = SPVAL albase(i,j) = SPVAL - enddo - enddo -! GFS does not have convective precip -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,cprate) - do j=jsta,jend - do i=1,im - cprate(i,j) = 0. + cprate(i,j) = 0.0 ! GFS does not have convective precip ???? enddo enddo @@ -604,7 +597,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp& shared(rlwtt,rswtt,tcucn,tcucns,train) do j=jsta_2l,jend_2u do i=1,im - rlwtt(i,j,l) = spval + rlwtt(i,j,l) = spval rswtt(i,j,l) = spval tcucn(i,j,l) = spval tcucns(i,j,l) = spval @@ -720,19 +713,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find lans sea mask found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),fieldName='land',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! if(mype==0) print *,'ibdl=',ibdl,'land, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'land',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) - !$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) +!$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) do j=jsta, jend do i=ista, iend if (arrayr42d(i,j) /= spval) sm(i,j) = 1.- arrayr42d(i,j) @@ -744,19 +737,17 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find ice fraction found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! if(mype==0) print *,'ibdl=',ibdl,'ice, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) do j=jsta, jend do i=ista, iend sice(i,j) = arrayr42d(i,j) @@ -768,9 +759,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo get_lsmsk if (.not.foundland .or. .not.foundice) then - rc=999 - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + rc = 999 + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return endif if(mype==0) print *,'after find sm and sice,imp_physics=',imp_physics,'nbdl=',wrt_int_state%FBCount ! @@ -778,29 +768,27 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! ! get grid dimension count ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl,'idim=', & -! ista,iend,'jdim=',jsta,jend +! ista,iend,'jdim=',jsta,jend call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), grid=wrtGrid, & - fieldCount=ncount_field, name=wrtFBName,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + fieldCount=ncount_field, name=wrtFBName,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! if(mype==0) print *,'in setvar, allocate fcstField,ibdl=',ibdl,'count=',ncount_field,'wrtFBname=',trim(wrtFBName) allocate(fcstField(ncount_field)) call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), & - fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl, 'nfield=',ncount_field + do n=1, ncount_field ! call ESMF_FieldGet(fcstField(n),typekind=typekind, name=fieldname, & - dimCount=fieldDimCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + dimCount=fieldDimCount,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (index(trim(fieldname),"vector") >0) cycle ! !** for 2D fields @@ -808,14 +796,14 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr82d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + allocate( arrayr42d(ista:iend,jsta:jend)) - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) do j=jsta, jend do i=ista, iend arrayr42d(i,j) = arrayr82d(i,j) @@ -824,58 +812,58 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! Terrain height (*G later) - if(trim(fieldname)=='hgtsfc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) + if(trim(fieldname) == 'hgtsfc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) do j=jsta,jend do i=ista, iend - fis(i,j)=arrayr42d(i,j) + fis(i,j) = arrayr42d(i,j) enddo enddo endif ! Surface pressure ! if(trim(fieldname)=='pressfc') then -! !$omp parallel do private(i,j) +!!$omp parallel do private(i,j) ! do j=jsta,jend ! do i=ista, iend -! pint(i,j)=arrayr42d(i,j) +! pint(i,j) = arrayr42d(i,j) ! enddo ! enddo ! endif ! PBL height using nemsio - if(trim(fieldname)=='hpbl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) + if(trim(fieldname) == 'hpbl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) do j=jsta,jend do i=ista, iend - pblh(i,j)=arrayr42d(i,j) + pblh(i,j) = arrayr42d(i,j) enddo enddo endif ! frictional velocity - if(trim(fieldname)=='fricv') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) + if(trim(fieldname) == 'fricv') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) do j=jsta,jend do i=ista, iend - ustar(i,j)=arrayr42d(i,j) + ustar(i,j) = arrayr42d(i,j) enddo enddo endif ! roughness length - if(trim(fieldname)=='sfcr') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) + if(trim(fieldname) == 'sfcr') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) do j=jsta,jend do i=ista, iend - z0(i,j)=arrayr42d(i,j) + z0(i,j) = arrayr42d(i,j) enddo enddo endif ! sfc exchange coeff - if(trim(fieldname)=='sfexc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) + if(trim(fieldname) == 'sfexc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) do j=jsta,jend do i=ista, iend sfcexc(i,j)=arrayr42d(i,j) @@ -884,18 +872,18 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! aerodynamic conductance - if(trim(fieldname)=='acond') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) + if(trim(fieldname) == 'acond') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) do j=jsta,jend do i=ista, iend - acond(i,j)=arrayr42d(i,j) + acond(i,j) = arrayr42d(i,j) enddo enddo endif ! surface potential T - if(trim(fieldname)=='tmpsfc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) + if(trim(fieldname) == 'tmpsfc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -906,114 +894,114 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! convective precip in m per physics time step - if(trim(fieldname)=='cpratb_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate) + if(trim(fieldname) == 'cpratb_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) & - avgcprate(i,j) = arrayr42d(i,j) * (dtq2*0.001) + avgcprate(i,j) = arrayr42d(i,j) * dtq2001 enddo enddo endif ! continuous bucket convective precip in m per physics time step - if(trim(fieldname)=='cprat_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate_cont) + if(trim(fieldname) =='cprat_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgcprate_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) + avgcprate_cont(i,j) = arrayr42d(i,j) * dtq2001 endif enddo enddo endif ! time averaged bucketed precip rate - if(trim(fieldname)=='prateb_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec) + if(trim(fieldname) == 'prateb_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec(i,j) = arrayr42d(i,j) * (dtq2*0.001) + avgprec(i,j) = arrayr42d(i,j) * dtq2001 endif enddo enddo endif ! time averaged continuous precip rate in m per physics time step - if(trim(fieldname)=='prate_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec_cont) + if(trim(fieldname) == 'prate_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) + avgprec_cont(i,j) = arrayr42d(i,j) * dtq2001 endif enddo enddo endif ! precip rate in m per physics time step - if(trim(fieldname)=='tprcp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,prec) + if(trim(fieldname) == 'tprcp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,prec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - prec(i,j) = arrayr42d(i,j) * (dtq2*0.001) * 1000./dtp + prec(i,j) = arrayr42d(i,j) * (dtq2001 * 1000./dtp) endif enddo enddo endif ! convective precip rate in m per physics time step - if(trim(fieldname)=='cnvprcp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,cprate) + if(trim(fieldname) == 'cnvprcp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,cprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2*0.001) * 1000./dtp + cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2001 * 1000./dtp) endif enddo enddo endif ! inst snow water eqivalent - if(trim(fieldname)=='weasd') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) + if(trim(fieldname) == 'weasd') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend sno(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j)==0.)sno(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) sno(i,j) = spval enddo enddo endif ! ave snow cover - if(trim(fieldname)=='snowc_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) + if(trim(fieldname) == 'snowc_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend snoavg(i,j) = arrayr42d(i,j) - if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) snoavg(i,j) = spval if (snoavg(i,j) /= spval) snoavg(i,j) = snoavg(i,j)/100. enddo enddo endif ! snow depth in mm - if(trim(fieldname)=='snod') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) + if(trim(fieldname) == 'snod') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend si(i,j) = arrayr42d(i,j) - if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) si(i,j)=spval if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 enddo enddo endif ! 2m potential T (computed later) - if(trim(fieldname)=='tmp2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) + if(trim(fieldname) == 'tmp2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) do j=jsta,jend do i=ista, iend tshltr(i,j) = arrayr42d(i,j) @@ -1022,8 +1010,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! surface potential T - if(trim(fieldname)=='spfh2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) + if(trim(fieldname) == 'spfh2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) do j=jsta,jend do i=ista, iend qshltr(i,j) = arrayr42d(i,j) @@ -1032,8 +1020,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! mid day avg albedo in fraction - if(trim(fieldname)=='albdo_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) + if(trim(fieldname) == 'albdo_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) do j=jsta,jend do i=ista, iend avgalbedo(i,j) = arrayr42d(i,j) @@ -1045,8 +1033,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname)=='tcdc_aveclm') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) + if(trim(fieldname) == 'tcdc_aveclm') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) do j=jsta,jend do i=ista, iend avgtcdc(i,j) = arrayr42d(i,j) @@ -1058,8 +1046,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! maximum snow albedo in fraction - if(trim(fieldname)=='snoalb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) + if(trim(fieldname) == 'snoalb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) do j=jsta,jend do i=ista, iend mxsnal(i,j) = arrayr42d(i,j) @@ -1071,8 +1059,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave high cloud fraction - if(trim(fieldname)=='tcdc_avehcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) + if(trim(fieldname) == 'tcdc_avehcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) do j=jsta,jend do i=ista, iend avgcfrach(i,j) = arrayr42d(i,j) @@ -1084,8 +1072,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave low cloud fraction - if(trim(fieldname)=='tcdc_avelcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) + if(trim(fieldname) == 'tcdc_avelcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracl(i,j) = arrayr42d(i,j) @@ -1097,8 +1085,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave middle cloud fraction - if(trim(fieldname)=='tcdc_avemcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) + if(trim(fieldname) == 'tcdc_avemcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracm(i,j) = arrayr42d(i,j) @@ -1110,8 +1098,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst convective cloud fraction - if(trim(fieldname)=='tcdccnvcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) + if(trim(fieldname) == 'tcdccnvcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) do j=jsta,jend do i=ista, iend cnvcfr(i,j) = arrayr42d(i,j) @@ -1123,8 +1111,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! slope type - if(trim(fieldname)=='sltyp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) + if(trim(fieldname) == 'sltyp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1137,8 +1125,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname)=='cnwat') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) + if(trim(fieldname) == 'cnwat') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) do j=jsta,jend do i=ista, iend cmc(i,j) = arrayr42d(i,j) @@ -1149,8 +1137,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! frozen precip fraction - if(trim(fieldname)=='cpofp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) + if(trim(fieldname) == 'cpofp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -1164,8 +1152,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sea ice skin temperature - if(trim(fieldname)=='tisfc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) + if(trim(fieldname) == 'tisfc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) do j=jsta,jend do i=ista,iend if (arrayr42d(i,j) /= spval) then @@ -1179,8 +1167,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation fraction - if(trim(fieldname)=='veg') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) + if(trim(fieldname) == 'veg') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) do j=jsta,jend do i=ista, iend vegfrc(i,j) = arrayr42d(i,j) @@ -1195,8 +1183,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname)=='soill1') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname) == 'soill1') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,1) = arrayr42d(i,j) @@ -1206,8 +1194,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname)=='soill2') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname) == 'soill2') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,2) = arrayr42d(i,j) @@ -1217,8 +1205,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname)=='soill3') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname) == 'soill3') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,3) = arrayr42d(i,j) @@ -1228,8 +1216,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname)=='soill4') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname) == 'soill4') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,4) = arrayr42d(i,j) @@ -1239,8 +1227,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname)=='soilw1') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname) == 'soilw1') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,1) = arrayr42d(i,j) @@ -1250,8 +1238,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname)=='soilw2') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname) == 'soilw2') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,2) = arrayr42d(i,j) @@ -1261,8 +1249,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname)=='soilw3') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname) == 'soilw3') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,3) = arrayr42d(i,j) @@ -1272,8 +1260,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname)=='soilw4') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname) == 'soilw4') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,4) = arrayr42d(i,j) @@ -1283,8 +1271,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname)=='soilt1') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname) == 'soilt1') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,1) = arrayr42d(i,j) @@ -1295,8 +1283,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname)=='soilt2') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname) == 'soilt2') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,2) = arrayr42d(i,j) @@ -1307,8 +1295,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname)=='soilt3') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname) == 'soilt3') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,3) = arrayr42d(i,j) @@ -1319,8 +1307,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname)=='soilt4') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname) == 'soilt4') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,4) = arrayr42d(i,j) @@ -1332,7 +1320,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged incoming sfc longwave if(trim(fieldname)=='dlwrf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) do j=jsta,jend do i=ista, iend alwin(i,j) = arrayr42d(i,j) @@ -1341,8 +1329,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc longwave - if(trim(fieldname)=='dlwrf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) + if(trim(fieldname) == 'dlwrf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) do j=jsta,jend do i=ista, iend rlwin(i,j) = arrayr42d(i,j) @@ -1351,8 +1339,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc longwave, CLDRAD puts a minus sign - if(trim(fieldname)=='ulwrf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) + if(trim(fieldname) == 'ulwrf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) do j=jsta,jend do i=ista, iend alwout(i,j) = arrayr42d(i,j) @@ -1362,8 +1350,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc longwave - if(trim(fieldname)=='ulwrf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) + if(trim(fieldname) == 'ulwrf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) do j=jsta,jend do i=ista, iend radot(i,j) = arrayr42d(i,j) @@ -1372,8 +1360,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing model top longwave - if(trim(fieldname)=='ulwrf_avetoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) + if(trim(fieldname) == 'ulwrf_avetoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) do j=jsta,jend do i=ista, iend alwtoa(i,j) = arrayr42d(i,j) @@ -1382,8 +1370,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc shortwave - if(trim(fieldname)=='dswrf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) + if(trim(fieldname) == 'dswrf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) do j=jsta,jend do i=ista, iend aswin(i,j) = arrayr42d(i,j) @@ -1392,8 +1380,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc shortwave - if(trim(fieldname)=='dswrf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) + if(trim(fieldname) == 'dswrf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) do j=jsta,jend do i=ista, iend rswin(i,j) = arrayr42d(i,j) @@ -1402,8 +1390,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc uv-b - if(trim(fieldname)=='duvb_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) + if(trim(fieldname) == 'duvb_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) do j=jsta,jend do i=ista, iend auvbin(i,j) = arrayr42d(i,j) @@ -1412,8 +1400,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc clear sky uv-b - if(trim(fieldname)=='cduvb_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) + if(trim(fieldname) == 'cduvb_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) do j=jsta,jend do i=ista, iend auvbinc(i,j) = arrayr42d(i,j) @@ -1422,8 +1410,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc shortwave,CLDRAD puts a minus sign - if(trim(fieldname)=='uswrf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) + if(trim(fieldname) == 'uswrf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) do j=jsta,jend do i=ista, iend aswout(i,j) = arrayr42d(i,j) @@ -1433,8 +1421,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc shortwave - if(trim(fieldname)=='uswrf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) + if(trim(fieldname) == 'uswrf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) do j=jsta,jend do i=ista, iend rswout(i,j) = arrayr42d(i,j) @@ -1443,8 +1431,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged model top incoming shortwave - if(trim(fieldname)=='dswrf_avetoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) + if(trim(fieldname) == 'dswrf_avetoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) do j=jsta,jend do i=ista, iend aswintoa(i,j) = arrayr42d(i,j) @@ -1453,8 +1441,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ime averaged model top outgoing shortwave - if(trim(fieldname)=='uswrf_avetoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) + if(trim(fieldname) == 'uswrf_avetoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) do j=jsta,jend do i=ista, iend aswtoa(i,j) = arrayr42d(i,j) @@ -1464,8 +1452,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface sensible heat flux, multiplied by -1 because ! wrf model fluxhas reversed sign convention using gfsio - if(trim(fieldname)=='shtfl_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) + if(trim(fieldname) == 'shtfl_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) do j=jsta,jend do i=ista, iend sfcshx(i,j) = arrayr42d(i,j) @@ -1475,8 +1463,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface sensible heat flux - if(trim(fieldname)=='shtfl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) + if(trim(fieldname) == 'shtfl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) do j=jsta,jend do i=ista, iend twbs(i,j) = arrayr42d(i,j) @@ -1487,8 +1475,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface latent heat flux, multiplied by -1 because ! wrf model flux has reversed sign vonvention using gfsio - if(trim(fieldname)=='lhtfl_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) + if(trim(fieldname) == 'lhtfl_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) do j=jsta,jend do i=ista, iend sfclhx(i,j) = arrayr42d(i,j) @@ -1498,8 +1486,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface latent heat flux - if(trim(fieldname)=='lhtfl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) + if(trim(fieldname) == 'lhtfl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) do j=jsta,jend do i=ista, iend qwbs(i,j) = arrayr42d(i,j) @@ -1509,30 +1497,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged ground heat flux - if(trim(fieldname)=='gflux_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) + if(trim(fieldname) == 'gflux_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend subshx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) subshx(i,j) = spval enddo enddo endif ! inst ground heat flux - if(trim(fieldname)=='gflux') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) + if(trim(fieldname) == 'gflux') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend grnflx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) grnflx(i,j) = spval enddo enddo endif ! time averaged zonal momentum flux - if(trim(fieldname)=='uflx_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) + if(trim(fieldname) == 'uflx_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) do j=jsta,jend do i=ista, iend sfcux(i,j) = arrayr42d(i,j) @@ -1541,8 +1529,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional momentum flux - if(trim(fieldname)=='vflx_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) + if(trim(fieldname) == 'vflx_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) do j=jsta,jend do i=ista, iend sfcvx(i,j) = arrayr42d(i,j) @@ -1551,8 +1539,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged zonal gravity wave stress - if(trim(fieldname)=='u-gwd_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) + if(trim(fieldname) == 'u-gwd_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) do j=jsta,jend do i=ista, iend gtaux(i,j) = arrayr42d(i,j) @@ -1561,8 +1549,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional gravity wave stress - if(trim(fieldname)=='v-gwd_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) + if(trim(fieldname) == 'v-gwd_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) do j=jsta,jend do i=ista, iend gtauy(i,j) = arrayr42d(i,j) @@ -1571,30 +1559,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged accumulated potential evaporation - if(trim(fieldname)=='pevpr_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) + if(trim(fieldname) == 'pevpr_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgpotevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgpotevp(i,j) = spval enddo enddo endif ! inst potential evaporation - if(trim(fieldname)=='pevpr') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) + if(trim(fieldname) == 'pevpr') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend potevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) potevp(i,j) = spval enddo enddo endif ! 10 m u - if(trim(fieldname)=='ugrd10m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) + if(trim(fieldname) == 'ugrd10m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) do j=jsta,jend do i=ista, iend u10(i,j) = arrayr42d(i,j) @@ -1604,8 +1592,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! 10 m v - if(trim(fieldname)=='vgrd10m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) + if(trim(fieldname) == 'vgrd10m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) do j=jsta,jend do i=ista, iend v10(i,j) = arrayr42d(i,j) @@ -1615,8 +1603,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation type - if(trim(fieldname)=='vtype') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) + if(trim(fieldname) == 'vtype') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1629,8 +1617,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil type - if(trim(fieldname)=='sotyp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) + if(trim(fieldname) == 'sotyp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1643,8 +1631,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud top pressure - if(trim(fieldname)=='prescnvclt') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) + if(trim(fieldname) == 'prescnvclt') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) do j=jsta,jend do i=ista, iend ptop(i,j) = arrayr42d(i,j) @@ -1654,8 +1642,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud bottom pressure - if(trim(fieldname)=='prescnvclb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) + if(trim(fieldname) == 'prescnvclb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) do j=jsta,jend do i=ista, iend pbot(i,j) = arrayr42d(i,j) @@ -1665,8 +1653,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top pressure - if(trim(fieldname)=='pres_avelct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) + if(trim(fieldname) == 'pres_avelct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) do j=jsta,jend do i=ista, iend ptopl(i,j) = arrayr42d(i,j) @@ -1675,8 +1663,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud bottom pressure - if(trim(fieldname)=='pres_avelcb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) + if(trim(fieldname) == 'pres_avelcb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) do j=jsta,jend do i=ista, iend pbotl(i,j) = arrayr42d(i,j) @@ -1685,8 +1673,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top temperature - if(trim(fieldname)=='tmp_avelct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) + if(trim(fieldname) == 'tmp_avelct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) do j=jsta,jend do i=ista, iend ttopl(i,j) = arrayr42d(i,j) @@ -1695,8 +1683,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top pressure - if(trim(fieldname)=='pres_avemct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) + if(trim(fieldname) == 'pres_avemct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) do j=jsta,jend do i=ista, iend ptopm(i,j) = arrayr42d(i,j) @@ -1705,8 +1693,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud bottom pressure - if(trim(fieldname)=='pres_avemcb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) + if(trim(fieldname) == 'pres_avemcb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) do j=jsta,jend do i=ista, iend pbotm(i,j) = arrayr42d(i,j) @@ -1715,8 +1703,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top temperature - if(trim(fieldname)=='tmp_avemct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) + if(trim(fieldname) == 'tmp_avemct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) do j=jsta,jend do i=ista, iend ttopm(i,j) = arrayr42d(i,j) @@ -1725,8 +1713,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top pressure - if(trim(fieldname)=='pres_avehct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) + if(trim(fieldname) == 'pres_avehct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) do j=jsta,jend do i=ista, iend ptoph(i,j) = arrayr42d(i,j) @@ -1735,8 +1723,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud bottom pressure - if(trim(fieldname)=='pres_avehcb') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) + if(trim(fieldname) == 'pres_avehcb') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) do j=jsta,jend do i=ista, iend pboth(i,j) = arrayr42d(i,j) @@ -1745,8 +1733,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top temperature - if(trim(fieldname)=='tmp_avehct') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) + if(trim(fieldname) == 'tmp_avehct') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) do j=jsta,jend do i=ista, iend ttoph(i,j) = arrayr42d(i,j) @@ -1755,8 +1743,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged boundary layer cloud cover - if(trim(fieldname)=='tcdc_avebndcl') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) + if(trim(fieldname) == 'tcdc_avebndcl') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) do j=jsta,jend do i=ista, iend pblcfr(i,j) = arrayr42d(i,j) @@ -1766,8 +1754,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! cloud work function - if(trim(fieldname)=='cwork_aveclm') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) + if(trim(fieldname) == 'cwork_aveclm') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) do j=jsta,jend do i=ista, iend cldwork(i,j) = arrayr42d(i,j) @@ -1776,8 +1764,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! water runoff - if(trim(fieldname)=='watr_acc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) + if(trim(fieldname) == 'watr_acc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) do j=jsta,jend do i=ista, iend runoff(i,j) = arrayr42d(i,j) @@ -1787,8 +1775,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max temperature - if(trim(fieldname)=='tmax_max2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) + if(trim(fieldname) == 'tmax_max2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxtshltr(i,j) = arrayr42d(i,j) @@ -1797,8 +1785,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname)=='tmin_min2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) + if(trim(fieldname) == 'tmin_min2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) do j=jsta,jend do i=ista, iend mintshltr(i,j) = arrayr42d(i,j) @@ -1807,8 +1795,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ice thickness - if(trim(fieldname)=='icetk') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) + if(trim(fieldname) == 'icetk') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) do j=jsta,jend do i=ista, iend dzice(i,j) = arrayr42d(i,j) @@ -1817,8 +1805,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! wilting point - if(trim(fieldname)=='wilt') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) + if(trim(fieldname) == 'wilt') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) do j=jsta,jend do i=ista, iend smcwlt(i,j) = arrayr42d(i,j) @@ -1828,8 +1816,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sunshine duration - if(trim(fieldname)=='sunsd_acc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) + if(trim(fieldname) == 'sunsd_acc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) do j=jsta,jend do i=ista, iend suntime(i,j) = arrayr42d(i,j) @@ -1838,8 +1826,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! field capacity - if(trim(fieldname)=='fldcp') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) + if(trim(fieldname) == 'fldcp') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) do j=jsta,jend do i=ista, iend fieldcapa(i,j) = arrayr42d(i,j) @@ -1849,8 +1837,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible beam downward solar flux - if(trim(fieldname)=='vbdsf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) + if(trim(fieldname) == 'vbdsf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend avisbeamswin(i,j) = arrayr42d(i,j) @@ -1859,8 +1847,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible diffuse downward solar flux - if(trim(fieldname)=='vddsf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) + if(trim(fieldname) == 'vddsf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend avisdiffswin(i,j) = arrayr42d(i,j) @@ -1869,8 +1857,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR beam downward solar flux - if(trim(fieldname)=='nbdsf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) + if(trim(fieldname) == 'nbdsf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend airbeamswin(i,j) = arrayr42d(i,j) @@ -1879,8 +1867,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR diffuse downward solar flux - if(trim(fieldname)=='nddsf_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) + if(trim(fieldname) == 'nddsf_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend airdiffswin(i,j) = arrayr42d(i,j) @@ -1889,8 +1877,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing LW - if(trim(fieldname)=='csulf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) + if(trim(fieldname) == 'csulf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) do j=jsta,jend do i=ista, iend alwoutc(i,j) = arrayr42d(i,j) @@ -1899,8 +1887,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing LW - if(trim(fieldname)=='csulftoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) + if(trim(fieldname) == 'csulftoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) do j=jsta,jend do i=ista, iend alwtoac(i,j) = arrayr42d(i,j) @@ -1909,8 +1897,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing SW - if(trim(fieldname)=='csusf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) + if(trim(fieldname) == 'csusf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) do j=jsta,jend do i=ista, iend aswoutc(i,j) = arrayr42d(i,j) @@ -1919,8 +1907,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing SW - if(trim(fieldname)=='csusftoa') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) + if(trim(fieldname) == 'csusftoa') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) do j=jsta,jend do i=ista, iend aswtoac(i,j) = arrayr42d(i,j) @@ -1929,8 +1917,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming LW - if(trim(fieldname)=='csdlf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) + if(trim(fieldname) == 'csdlf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) do j=jsta,jend do i=ista, iend alwinc(i,j) = arrayr42d(i,j) @@ -1939,8 +1927,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming SW - if(trim(fieldname)=='csdsf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) + if(trim(fieldname) == 'csdsf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) do j=jsta,jend do i=ista, iend aswinc(i,j) = arrayr42d(i,j) @@ -1949,8 +1937,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max specific humidity - if(trim(fieldname)=='spfhmax_max2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) + if(trim(fieldname) == 'spfhmax_max2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxqshltr(i,j) = arrayr42d(i,j) @@ -1959,8 +1947,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname)=='spfhmin_min2m') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) + if(trim(fieldname) == 'spfhmin_min2m') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) do j=jsta,jend do i=ista, iend minqshltr(i,j) = arrayr42d(i,j) @@ -1969,8 +1957,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! storm runoffs - if(trim(fieldname)=='ssrun_acc') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) + if(trim(fieldname) == 'ssrun_acc') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) do j=jsta,jend do i=ista, iend ssroff(i,j) = arrayr42d(i,j) @@ -1980,8 +1968,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! direct soil evaporation - if(trim(fieldname)=='evbs_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) + if(trim(fieldname) == 'evbs_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgedir(i,j) = arrayr42d(i,j) @@ -1991,8 +1979,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! canopy water evap - if(trim(fieldname)=='evcw_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) + if(trim(fieldname) == 'evcw_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgecan(i,j) = arrayr42d(i,j) @@ -2002,8 +1990,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! plant transpiration - if(trim(fieldname)=='trans_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) + if(trim(fieldname) == 'trans_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgetrans(i,j) = arrayr42d(i,j) @@ -2013,19 +2001,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow sublimation - if(trim(fieldname)=='sbsno_ave') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) + if(trim(fieldname) == 'sbsno_ave') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgesnow(i,j) = arrayr42d(i,j) - if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval + if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgesnow(i,j) = spval enddo enddo endif ! total soil moisture - if(trim(fieldname)=='soilm') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) + if(trim(fieldname) == 'soilm') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) do j=jsta,jend do i=ista, iend smstot(i,j) = arrayr42d(i,j) @@ -2035,8 +2023,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow phase change heat flux - if(trim(fieldname)=='snohf') then - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) + if(trim(fieldname) == 'snohf') then +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) do j=jsta,jend do i=ista, iend snopcx(i,j) = arrayr42d(i,j) @@ -2046,19 +2034,17 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! else if (fieldDimCount > gridDimCount) then - else if (fieldDimCount ==3) then + else if (fieldDimCount == 3) then if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr43d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr83d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & - line=__LINE__, file=__FILE__)) return ! bail out + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return allocate(arrayr43d(ista:iend,jsta:jend,kstart:kend)) arrayr43d = 0. do k=kstart,kend - !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) do j=jsta,jend do i=ista,iend arrayr43d(i,j,k) = arrayr83d(i,j,k) @@ -2068,8 +2054,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level T - if(trim(fieldname)=='tmp') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) + if(trim(fieldname) == 'tmp') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend @@ -2079,7 +2065,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo !! sig4 - !$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) +!$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) do j=jsta,jend do i=ista, iend tlmh = t(i,j,lm) * t(i,j,lm) @@ -2089,172 +2075,237 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level spfh - if(trim(fieldname)=='spfh') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) + if(trim(fieldname) == 'spfh') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q(i,j,l)=arrayr43d(i,j,l) + q(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level u wind - if(trim(fieldname)=='ugrd') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) + if(trim(fieldname) == 'ugrd') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - uh(i,j,l)=arrayr43d(i,j,l) + uh(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level v wind - if(trim(fieldname)=='vgrd') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) + if(trim(fieldname) == 'vgrd') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - vh(i,j,l)=arrayr43d(i,j,l) + vh(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level pressure thinkness - if(trim(fieldname)=='dpres') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) + if(trim(fieldname) == 'dpres') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - dpres(i,j,l)=arrayr43d(i,j,l) + dpres(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level gh thinkness, model output negative delz - if(trim(fieldname)=='delz') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) + if(trim(fieldname) == 'delz') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - zint(i,j,l)=-1.*arrayr43d(i,j,l) + zint(i,j,l) = -arrayr43d(i,j,l) enddo enddo enddo endif ! model level w - if(trim(fieldname)=='dzdt') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) + if(trim(fieldname) == 'dzdt') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - wh(i,j,l)=arrayr43d(i,j,l) + wh(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level ozone mixing ratio - if(trim(fieldname)=='o3mr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) + if(trim(fieldname) == 'o3mr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - o3(i,j,l)=arrayr43d(i,j,l) + o3(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif -! for GFDL MP - if (imp_physics == 11) then +! for GFDL or MG3 MP +! ------------------ + if (imp_physics == 10 .or. imp_physics == 11) then ! model level cloud water mixing ratio - if(trim(fieldname)=='clwmr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) + if(trim(fieldname) == 'clwmr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqw(i,j,l)=arrayr43d(i,j,l) + qqw(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level ice mixing ratio - if(trim(fieldname)=='icmr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) + if(trim(fieldname) == 'icmr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqi(i,j,l)=arrayr43d(i,j,l) + qqi(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname)=='rwmr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) + if(trim(fieldname) == 'rwmr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqr(i,j,l)=arrayr43d(i,j,l) + qqr(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level snow mixing ratio - if(trim(fieldname)=='snmr') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) + if(trim(fieldname) == 'snmr') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqs(i,j,l)=arrayr43d(i,j,l) + qqs(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname)=='grle') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) + if(trim(fieldname) == 'grle') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqg(i,j,l)=arrayr43d(i,j,l) + qqg(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + endif !gfdlmp or MG3 mp +! for MG3 MP +! ---------- + if (imp_physics == 10) then + ! model level cloud water mixing ratio number concentration + if(trim(fieldname) == 'clwnc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnw,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqnw(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + ! model level ice mixing ratio number concentration + if(trim(fieldname) == 'icenc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqni,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqni(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + ! model level rain water mixing ratio number concentration + if(trim(fieldname) == 'rwnc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnr,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqnr(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + ! model level snow mixing ratio number concentration + if(trim(fieldname) == 'snnc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqns,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqns(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif -!gfdlmp - endif + + ! model level rain water mixing ratio number concentration + if(trim(fieldname) == 'grlenc') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqng,arrayr43d) + do l=1,lm + do j=jsta,jend + do i=ista, iend + qqng(i,j,l) = arrayr43d(i,j,l) + enddo + enddo + enddo + endif + + endif ! for MG3 MP ! model level cloud amount - if(trim(fieldname)=='cld_amt') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) + if(trim(fieldname) == 'cld_amt') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - cfr(i,j,l)=arrayr43d(i,j,l) + cfr(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo endif ! model level ref3d - if(trim(fieldname)=='ref3D') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) + if(trim(fieldname) == 'ref3D') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - ref_10cm(i,j,l)=arrayr43d(i,j,l) + ref_10cm(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo @@ -2262,12 +2313,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level ref3d - if(trim(fieldname)=='tke') then - !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) + if(trim(fieldname) == 'tke') then +!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q2(i,j,l)=arrayr43d(i,j,l) + q2(i,j,l) = arrayr43d(i,j,l) enddo enddo enddo @@ -2275,8 +2326,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !3d fields endif -! end loop ncount_field - enddo + enddo ! end loop ncount_field if ( index(trim(wrt_int_state%wrtFB_names(ibdl)),trim(filename_base(1))) > 0) & setvar_atmfile = .true. @@ -2302,46 +2352,33 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,omga,wh,dpres,zint) do j=jsta,jend do i=1,im - omga(i,j,l) = (-1.) * wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) + omga(i,j,l) = - wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) zint(i,j,l) = zint(i,j,l) + zint(i,j,l+1) enddo enddo enddo ! compute pint from top down -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint,pd,spval) do j=jsta,jend do i=1,im pint(i,j,1) = ak5(1) - end do - end do + pd(i,j) = spval + enddo + enddo do l=2,lp1 -!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pint,dpres) + ll = l - 1 +!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,pint,dpres,pmid) do j=jsta,jend do i=1,im - pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) - enddo - enddo - end do - + pint(i,j,l) = pint(i,j,ll) + dpres(i,j,ll) !compute pmid from averaged two layer pint - do l=lm,1,-1 -!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pmid,pint) - do j=jsta,jend - do i=1,im - pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) + pmid(i,j,ll) = 0.5*(pint(i,j,ll)+pint(i,j,l)) enddo enddo enddo -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,spval,pt,pd,pint) - do j=jsta,jend - do i=1,im - pd(i,j) = spval - pint(i,j,1) = pt - end do - end do ! print *,'in setvar, pt=',pt,'ak5(lp1)=', ak5(lp1),'ak5(1)=',ak5(1) ! compute alpint @@ -2349,22 +2386,23 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,alpint,pint) do j=jsta,jend do i=1,im - alpint(i,j,l)=log(pint(i,j,l)) - end do - end do - end do + alpint(i,j,l) = log(pint(i,j,l)) + enddo + enddo + enddo ! compute zmid do l=lm,1,-1 -!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,zmid,zint,pmid,alpint) + ll = l + 1 +!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,zmid,zint,pmid,alpint) do j=jsta,jend do i=1,im - zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & - (log(pmid(i,j,l))-alpint(i,j,l+1))/ & - (alpint(i,j,l)-alpint(i,j,l+1)) - end do - end do - end do + zmid(i,j,l) = zint(i,j,ll) + (zint(i,j,l)-zint(i,j,ll)) & + * (log(pmid(i,j,l))-alpint(i,j,ll)) & + / (alpint(i,j,l)-alpint(i,j,ll)) + enddo + enddo + enddo ! print *,'in post_gfs,zmid=',maxval(zmid(1:im,jsta:jend,1)), & ! minval(zmid(1:im,jsta:jend,1)),maxloc(zmid(1:im,jsta:jend,1)), & ! 'zint=',maxval(zint(1:im,jsta:jend,2)),minval(zint(1:im,jsta:jend,1)), & @@ -2390,13 +2428,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo enddo -! compute cwm for gfdlmp - if( imp_physics == 11 ) then +! compute cwm for gfdlmp or MG3 + if( imp_physics == 10 .or. imp_physics == 11) then do l=1,lm !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,ista,iend,cwm,qqg,qqs,qqr,qqi,qqw) do j=jsta,jend do i=ista,iend - cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) + cwm(i,j,l) = qqg(i,j,l) + qqs(i,j,l) + qqr(i,j,l) + qqi(i,j,l) + qqw(i,j,l) enddo enddo enddo @@ -2406,8 +2444,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,lm,pshltr,pint,tshltr) do j=jsta,jend do i=ista, iend - pshltr(I,J)=pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j)= tshltr(i,j)*(p1000/pshltr(I,J))**CAPA + pshltr(I,J) = pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) + tshltr(i,j) = tshltr(i,j)*(p1000/pshltr(I,J))**CAPA enddo enddo @@ -2418,13 +2456,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if(ptop(i,j) < spval)then do l=1,lm if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j)=l + htop(i,j) = l exit - end if - end do - end if - end do - end do + endif + enddo + endif + enddo + enddo ! hbot do j=jsta,jend From 86220446409d3ec3b2f77c7b853f48376bbead6b Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 9 Sep 2020 00:21:30 +0000 Subject: [PATCH 87/91] adding a new suite --- .../suites/suite_FV3_GFS_2017_couplednsst.xml | 89 +++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml diff --git a/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml b/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml new file mode 100644 index 000000000..241b8cc0c --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml @@ -0,0 +1,89 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + lsm_noah + sfc_nst_pre + sfc_nst + sfc_nst_post + sfc_cice + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + hedmf + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + samfdeepcnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + zhaocarr_gscond + zhaocarr_precpd + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + From 540273975921bb814a0ef8c7f4a64ebbff6437a6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 10 Sep 2020 21:24:27 -0400 Subject: [PATCH 88/91] updating .gitmodules and some fix in FV3GFS_io --- .gitmodules | 8 +-- atmos_cubed_sphere | 2 +- ccpp/physics | 2 +- .../suites/suite_FV3_GFS_2017_couplednsst.xml | 2 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 72 ++++++++++--------- io/FV3GFS_io.F90 | 2 +- 6 files changed, 48 insertions(+), 40 deletions(-) diff --git a/.gitmodules b/.gitmodules index d253f6966..1feca5aca 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,12 +1,12 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere - branch = dev/emc + url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere + branch = SM_Aug272020 [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/NCAR/ccpp-framework branch = master [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NCAR/ccpp-physics - branch = master + url = https://github.com/SMoorthi-emc/ccpp-physics + branch = SM_Sep09092020 diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 8b59ebc03..7be41cc1e 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 8b59ebc039dafe1c20ed6dd21cb38ca564852b98 +Subproject commit 7be41cc1e49428c808741dd1f1aaf3f931b41fed diff --git a/ccpp/physics b/ccpp/physics index 0808cc2e8..736f8f677 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 0808cc2e8938ba66003b46746858143a9d75addb +Subproject commit 736f8f67701733926d7b653121772caf5d797adb diff --git a/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml b/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml index 241b8cc0c..1aa7ca484 100644 --- a/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml +++ b/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml @@ -1,6 +1,6 @@ - + diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 8c2273f2c..62b48b872 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -814,8 +814,8 @@ subroutine GFS_physics_driver & ! do i=1,im ! lprnt = Model%me == 23 .and. i == 25 ! lprnt = Model%me == 127 .and. i == 11 -! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-102.65) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg-0.12) < 0.201 +! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-295.40) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-47.0) < 0.101 ! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-184.00) < 0.301 & ! .and. abs(grid%xlat(i)*rad2dg-83.23) < 0.301 ! lprnt = kdt >= 7 .and. abs(grid%xlon(i)*rad2dg-216.20) < 0.101 & @@ -2183,17 +2183,17 @@ subroutine GFS_physics_driver & endif if (islmsk(i) == 1) then k = 1 - Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land stress(i) = stress3(i,1) ! Sfcprop%tprcp(i) = tprcp3(i,1) + Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land Sfcprop%tsfco(i) = tsfc3(i,1) Sfcprop%tisfc(i) = tsfc3(i,1) Sfcprop%tsfc(i) = tsfc3(i,1) elseif (islmsk(i) == 0) then k = 3 - Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake (and ocean when uncoupled) stress(i) = stress3(i,3) ! Sfcprop%tprcp(i) = tprcp3(i,3) + Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake (and ocean when uncoupled) Sfcprop%tisfc(i) = tsfc3(i,3) Sfcprop%tsfcl(i) = tsfc3(i,3) Sfcprop%tsfc(i) = tsfc3(i,3) @@ -2201,6 +2201,7 @@ subroutine GFS_physics_driver & k = 2 stress(i) = stress3(i,2) ! Sfcprop%tprcp(i) = fice(i)*tprcp3(i,2) + (one-fice(i))*tprcp3(i,3) + Sfcprop%tsfc(i) = tsfc3(i,2) endif Sfcprop%zorl(i) = zorl3(i,k) cd(i) = cd3(i,k) @@ -2227,37 +2228,43 @@ subroutine GFS_physics_driver & Sfcprop%zorli(i) = zorl3(i,2) Sfcprop%zorlo(i) = zorl3(i,3) - if (flag_cice(i)) then - if (wet(i) .and. fice(i) > Model%min_seaice) then ! this was already done for lake ice in sfc_sice - txi = fice(i) - txo = one - txi - evap(i) = txi * evap3(i,2) + txo * evap3(i,3) - hflx(i) = txi * hflx3(i,2) + txo * hflx3(i,3) - Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) - stress(i) = txi *stress3(i,2) + txo * stress3(i,3) - qss(i) = txi * qss3(i,2) + txo * qss3(i,3) - ep1d(i) = txi * ep1d3(i,2) + txo * ep1d3(i,3) - Sfcprop%zorl(i) = txi * zorl3(i,2) + txo * zorl3(i,3) + if (k == 2) then + if (wet(i)) then + Sfcprop%tsfco(i) = tsfc3(i,3) + endif + if (flag_cice(i)) then + if (wet(i) .and. fice(i) > Model%min_seaice) then ! this was already done for lake ice in sfc_sice + txi = fice(i) + txo = one - txi + evap(i) = txi * evap3(i,2) + txo * evap3(i,3) + hflx(i) = txi * hflx3(i,2) + txo * hflx3(i,3) + Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) + stress(i) = txi *stress3(i,2) + txo * stress3(i,3) + qss(i) = txi * qss3(i,2) + txo * qss3(i,3) + ep1d(i) = txi * ep1d3(i,2) + txo * ep1d3(i,3) + Sfcprop%zorl(i) = txi * zorl3(i,2) + txo * zorl3(i,3) + endif + elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array + Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + Sfcprop%tsfc(i) = tsfc3(i,2) + Sfcprop%hice(i) = zice(i) + Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen + Sfcprop%zorl(i) = fice(i)*zorl3(i,2) + (one-fice(i))*zorl3(i,3) + else ! this would be over open ocean or land (no ice fraction) + Sfcprop%hice(i) = zero + Sfcprop%fice(i) = zero + Sfcprop%tsfc(i) = Sfcprop%tsfco(i) + Sfcprop%tisfc(i) = Sfcprop%tsfc(i) + icy(i) = .false. + endif + Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) + if (.not. wet(i)) then + Sfcprop%tsfco(i) =Sfcprop%tsfc(i) endif - elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array - Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - Sfcprop%hice(i) = zice(i) - Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen - Sfcprop%zorl(i) = fice(i)*zorl3(i,2) + (one-fice(i))*zorl3(i,3) - else ! this would be over open ocean or land (no ice fraction) - Sfcprop%hice(i) = zero - Sfcprop%fice(i) = zero - Sfcprop%tisfc(i) = Sfcprop%tsfc(i) - icy(i) = .false. - endif - Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) - if (wet(i)) then - Sfcprop%tsfco(i) = tsfc3(i,3) - else - Sfcprop%tsfco(i) =Sfcprop%tsfc(i) endif do k=1,Model%kice ! store tiice in stc to reduce output in the nonfrac grid case - Sfcprop%stc(i,k) = Sfcprop%tiice(i,k) +! Sfcprop%stc(i,k) = Sfcprop%tiice(i,k) + Sfcprop%stc(i,k) = stsoil(i,k) enddo enddo endif ! if (Model%frac_grid) @@ -5808,6 +5815,7 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)' end driver sfcprop%tsfcl=',Sfcprop%tsfcl(ipr),' kdt=',kdt ! if (lprnt) write(0,*)' end driver sfcprop%tsfco=',Sfcprop%tsfco(ipr),' kdt=',kdt ! if (lprnt) write(0,*)' end driver sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt +! if (lprnt) write(0,*)' end driver sfcprop%tsfc=',Sfcprop%tsfc(ipr),' kdt=',kdt,wet(ipr),icy(ipr),dry(ipr) ! endif return diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 329eac5ec..458605c96 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1357,7 +1357,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo else - if (Model%kdt <= 0) then + if( Model%phour < 1.e-7) then !$omp parallel do default(shared) private(nb, ix, tem) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) From 7e2cfe822c61854065f70a9e91eec81a03559b74 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 22 Sep 2020 00:06:12 +0000 Subject: [PATCH 89/91] after gitmoduel sync --- atmos_cubed_sphere | 2 +- ccpp/physics | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 7be41cc1e..a976dba87 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 7be41cc1e49428c808741dd1f1aaf3f931b41fed +Subproject commit a976dba8761821a3b085e057de926543da5a6833 diff --git a/ccpp/physics b/ccpp/physics index 736f8f677..28cf65480 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 736f8f67701733926d7b653121772caf5d797adb +Subproject commit 28cf654806dd1ec6d8ff88386a80a2e683002f3b From 6390ec7c128ee4b5b44f8efaee5a978392164b51 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 24 Sep 2020 20:56:23 -0400 Subject: [PATCH 90/91] after syncing submodules --- atmos_cubed_sphere | 2 +- ccpp/physics | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 7be41cc1e..32a406a13 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 7be41cc1e49428c808741dd1f1aaf3f931b41fed +Subproject commit 32a406a13283337358aeef33685176ad43f9fb01 diff --git a/ccpp/physics b/ccpp/physics index 736f8f677..28cf65480 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 736f8f67701733926d7b653121772caf5d797adb +Subproject commit 28cf654806dd1ec6d8ff88386a80a2e683002f3b From 8e47927485803cf79329907f6ea65a6024157537 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 25 Sep 2020 14:25:54 +0000 Subject: [PATCH 91/91] creating a new branch for PR --- .gitmodules | 8 +- io/post_gfs.F90 | 922 +++++++++++++++++++++++------------------------- 2 files changed, 446 insertions(+), 484 deletions(-) diff --git a/.gitmodules b/.gitmodules index 1feca5aca..d253f6966 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,12 +1,12 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - url = https://github.com/SMoorthi-emc/GFDL_atmos_cubed_sphere - branch = SM_Aug272020 + url = https://github.com/NOAA-EMC/GFDL_atmos_cubed_sphere + branch = dev/emc [submodule "ccpp/framework"] path = ccpp/framework url = https://github.com/NCAR/ccpp-framework branch = master [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/SMoorthi-emc/ccpp-physics - branch = SM_Sep09092020 + url = https://github.com/NCAR/ccpp-physics + branch = master diff --git a/io/post_gfs.F90 b/io/post_gfs.F90 index 248ce6d06..76dd0251c 100644 --- a/io/post_gfs.F90 +++ b/io/post_gfs.F90 @@ -112,20 +112,19 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & !----------------------------------------------------------------------- ! ! if(mype==0) print *,'in post_run,be post_alctvars, dim=',wrt_int_state%im, & -! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & -! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & +! wrt_int_state%jm, wrt_int_state%lm,'mype=',mype,'wrttasks_per_group=', & +! wrttasks_per_group,'lead_write=',lead_write,'jts=',jts,'jte=',jte, & ! 'jstagrp=',jstagrp,'jendgrp=',jendgrp - - call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & - wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & - mpicomp,jts,jte,jstagrp,jendgrp) + call post_alctvars(wrt_int_state%im,wrt_int_state%jm, & + wrt_int_state%lm,mype,wrttasks_per_group,lead_write, & + mpicomp,jts,jte,jstagrp,jendgrp) ! !----------------------------------------------------------------------- !*** read namelist for pv,th,po !----------------------------------------------------------------------- ! - log_postalct = .true. - first_grbtbl = .true. + log_postalct = .true. + first_grbtbl = .true. read_postcntrl = .true. ! ENDIF @@ -138,16 +137,16 @@ subroutine post_run_gfs(wrt_int_state,mypei,mpicomp,lead_write, & ifmin = mynfmin if (ifhr == 0 ) ifmin = 0 if(mype==0) print *,'bf set_postvars,ifmin=',ifmin,'ifhr=',ifhr - setvar_atmfile = .false. - setvar_sfcfile = .false. + setvar_atmfile=.false. + setvar_sfcfile=.false. call set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & - setvar_sfcfile) + setvar_sfcfile) ! print *,'af set_postvars,setvar_atmfile=',setvar_atmfile, & ! 'setvar_sfcfile=',setvar_sfcfile ! if (setvar_atmfile.and.setvar_sfcfile) then -! 20190807 need to call microinit only for Ferrier microphysics +! 20190807 no need to call microinit for GFDLMP ! call MICROINIT ! if(grib=="grib2" .and. read_postcntrl) then @@ -240,62 +239,66 @@ subroutine post_getattr_gfs(wrt_int_state, fldbundle) ! look at the field bundle attributes call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, Count=attcount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__,file=__FILE__))return ! bail out ! aklen=0. do i=1, attCount - call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & - typekind=typekind, itemCount=n, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__,file=__FILE__))return + call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & + attnestflag=ESMF_ATTNEST_OFF, attributeIndex=i, name=attName, & + typekind=typekind, itemCount=n, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__,file=__FILE__))return ! bail out if (typekind==ESMF_TYPEKIND_I4 ) then - if(n == 1) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varival, rc=rc) - if (trim(attName) == 'ncnsto') wrt_int_state%ntrac = varival - if (trim(attName) == 'ncld') wrt_int_state%ncld = varival - if (trim(attName) == 'nsoil') wrt_int_state%nsoil = varival - if (trim(attName) == 'fhzero') wrt_int_state%fhzero = varival - if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics = varival + name=trim(attName), value=varival, rc=rc) + if (trim(attName) == 'ncnsto') wrt_int_state%ntrac=varival + if (trim(attName) == 'ncld') wrt_int_state%ncld=varival + if (trim(attName) == 'nsoil') wrt_int_state%nsoil=varival + if (trim(attName) == 'fhzero') wrt_int_state%fhzero=varival + if (trim(attName) == 'imp_physics') wrt_int_state%imp_physics=varival endif - else if (typekind == ESMF_TYPEKIND_R4) then - if(n == 1) then + else if (typekind==ESMF_TYPEKIND_R4) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), value=varr4val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + name=trim(attName), value=varr4val, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr4val endif - else if(n > 1) then + else if(n>1) then if(trim(attName) =="ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 - else if(trim(attName) == "bk") then + else if(trim(attName) =="bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) allocate(wrt_int_state%bk(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%bk, rc=rc) + name=trim(attName), valueList=wrt_int_state%bk, rc=rc) endif endif - else if (typekind == ESMF_TYPEKIND_R8) then - if(n == 1) then + else if (typekind==ESMF_TYPEKIND_R8) then + if(n==1) then call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & name=trim(attName), value=varr8val, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (trim(attName) == 'dtp') then wrt_int_state%dtp=varr8val endif - else if(n > 1) then - if(trim(attName) == "ak") then + else if(n>1) then + if(trim(attName) =="ak") then if(allocated(wrt_int_state%ak)) deallocate(wrt_int_state%ak) allocate(wrt_int_state%ak(n)) call ESMF_AttributeGet(fldbundle, convention="NetCDF", purpose="FV3", & - name=trim(attName), valueList=wrt_int_state%ak, rc=rc) + name=trim(attName), valueList=wrt_int_state%ak, rc=rc) wrt_int_state%lm = n-1 else if(trim(attName) =="bk") then if(allocated(wrt_int_state%bk)) deallocate(wrt_int_state%bk) @@ -329,8 +332,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use vrbls3d, only: t, q, uh, vh, wh, alpint, dpres, zint, zmid, o3, & qqr, qqs, cwm, qqi, qqw, qqg, omga, cfr, pmid, & q2, rlwtt, rswtt, tcucn, tcucns, train, el_pbl, & - pint, exch_h, ref_10cm, & - qqnw, qqni, qqnr, qqns, qqng + pint, exch_h, ref_10cm use vrbls2d, only: f, pd, sigt4, fis, pblh, ustar, z0, ths, qs, twbs,& qwbs, avgcprate, cprate, avgprec, prec, lspa, sno,& cldefi, th10, q10, tshltr, pshltr, tshltr, albase,& @@ -358,11 +360,11 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & use soil, only: sldpth, sh2o, smc, stc use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice use ctlblk_mod, only: im, jm, lm, lp1, jsta, jend, jsta_2l, jend_2u, jsta_m,jend_m, & - lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & - tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & + lsm, pt, imp_physics, spval, mpi_comm_comp, gdsdegr, & + tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, theat, & ardlw, ardsw, asrfc, avrain, avcnvc, iSF_SURFACE_PHYSICS,& - td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & - alsl, spl, ihrst + td3d, idat, sdat, ifhr, ifmin, dt, nphs, dtq2, pt_tbl, & + alsl, spl, ihrst use params_mod, only: erad, dtr, capa, p1000 use gridspec_mod,only: latstart, latlast, lonstart, lonlast, cenlon, cenlat use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, & @@ -387,12 +389,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! !----------------------------------------------------------------------- ! - integer i, ip1, j, l, ll, k, n, iret, ibdl, rc, kstart, kend + integer i, ip1, j, l, k, n, iret, ibdl, rc, kstart, kend integer ista,iend,fieldDimCount,gridDimCount,ncount_field integer jdate(8) logical foundland, foundice, found real(4) rinc(5) - real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp, dtq2001 + real tlmh,RADI,TMP,ES,TV,RHOAIR,tem,tstart,dtp real, dimension(:),allocatable :: ak5, bk5 real(4),dimension(:,:),pointer :: arrayr42d real(8),dimension(:,:),pointer :: arrayr82d @@ -471,7 +473,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & end do ! ! GFS does not output PD - pt = ak5(1) + pt = ak5(1) ! GFS may not have model derived radar ref. ! TKE @@ -482,7 +484,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & do j=jsta,jend do i=1,im ref_10cm(i,j,l) = SPVAL - q2(i,j,l) = SPVAL + q2(i,j,l) = SPVAL cfr(i,j,l) = SPVAL enddo enddo @@ -494,10 +496,10 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none),private(i,j),shared(jsta,jend,im,spval,qs,twbs,qwbs,ths) do j=jsta,jend do i=1,im - qs(i,j) = SPVAL + qs(i,j) = SPVAL twbs(i,j) = SPVAL qwbs(i,j) = SPVAL - ths(i,j) = SPVAL + ths(i,j) = SPVAL enddo enddo @@ -505,7 +507,6 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & dtq2 = wrt_int_state%dtp nphs = 2. dt = dtq2/nphs - dtq2001 = dtq2*0.001 ! ! GFS does not have convective cloud efficiency ! similated precip @@ -513,16 +514,22 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! 10 m humidity ! snow free albedo !$omp parallel do default(none), private(i,j), shared(jsta,jend,im,spval), & -!$omp& shared(cldefi,lspa,th10,q10,albase,cprate) +!$omp& shared(cldefi,lspa,th10,q10,albase) do j=jsta,jend do i=1,im cldefi(i,j) = SPVAL - lspa(i,j) = SPVAL - th10(i,j) = SPVAL - q10(i,j) = SPVAL + lspa(i,j) = SPVAL + th10(i,j) = SPVAL + q10(i,j) = SPVAL albase(i,j) = SPVAL + enddo + enddo - cprate(i,j) = 0.0 ! GFS does not have convective precip ???? +! GFS does not have convective precip +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,cprate) + do j=jsta,jend + do i=1,im + cprate(i,j) = 0. enddo enddo @@ -597,7 +604,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp& shared(rlwtt,rswtt,tcucn,tcucns,train) do j=jsta_2l,jend_2u do i=1,im - rlwtt(i,j,l) = spval + rlwtt(i,j,l) = spval rswtt(i,j,l) = spval tcucn(i,j,l) = spval tcucns(i,j,l) = spval @@ -713,19 +720,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find lans sea mask found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),fieldName='land',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'ibdl=',ibdl,'land, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'land',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) -!$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) + !$omp parallel do default(none),private(i,j),shared(jsta,jend,ista,iend,spval,arrayr42d,sm) do j=jsta, jend do i=ista, iend if (arrayr42d(i,j) /= spval) sm(i,j) = 1.- arrayr42d(i,j) @@ -737,17 +744,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! find ice fraction found = .false. call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',isPresent=found, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'ibdl=',ibdl,'ice, found=',found if (found) then call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl),'icec',field=theField, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_FieldGet(theField, localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ista = lbound(arrayr42d,1) iend = ubound(arrayr42d,1) -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,sm) do j=jsta, jend do i=ista, iend sice(i,j) = arrayr42d(i,j) @@ -759,8 +768,9 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo get_lsmsk if (.not.foundland .or. .not.foundice) then - rc = 999 - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + rc=999 + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out endif if(mype==0) print *,'after find sm and sice,imp_physics=',imp_physics,'nbdl=',wrt_int_state%FBCount ! @@ -768,27 +778,29 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! ! get grid dimension count ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl,'idim=', & -! ista,iend,'jdim=',jsta,jend +! ista,iend,'jdim=',jsta,jend call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), grid=wrtGrid, & - fieldCount=ncount_field, name=wrtFBName,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + fieldCount=ncount_field, name=wrtFBName,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out call ESMF_GridGet(wrtgrid, dimCount=gridDimCount, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'in setvar, allocate fcstField,ibdl=',ibdl,'count=',ncount_field,'wrtFBname=',trim(wrtFBName) allocate(fcstField(ncount_field)) call ESMF_FieldBundleGet(wrt_int_state%wrtFB(ibdl), & - fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + fieldList=fcstField, itemorderflag=ESMF_ITEMORDER_ADDORDER, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out ! if(mype==0) print *,'in setvar, read field, ibdl=',ibdl, 'nfield=',ncount_field - do n=1, ncount_field ! call ESMF_FieldGet(fcstField(n),typekind=typekind, name=fieldname, & - dimCount=fieldDimCount,rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + dimCount=fieldDimCount,rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out if (index(trim(fieldname),"vector") >0) cycle ! !** for 2D fields @@ -796,14 +808,14 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr42d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr82d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out allocate( arrayr42d(ista:iend,jsta:jend)) -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,arrayr42d,arrayr82d) do j=jsta, jend do i=ista, iend arrayr42d(i,j) = arrayr82d(i,j) @@ -812,58 +824,58 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! Terrain height (*G later) - if(trim(fieldname) == 'hgtsfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) + if(trim(fieldname)=='hgtsfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,fis,arrayr42d) do j=jsta,jend do i=ista, iend - fis(i,j) = arrayr42d(i,j) + fis(i,j)=arrayr42d(i,j) enddo enddo endif ! Surface pressure ! if(trim(fieldname)=='pressfc') then -!!$omp parallel do private(i,j) +! !$omp parallel do private(i,j) ! do j=jsta,jend ! do i=ista, iend -! pint(i,j) = arrayr42d(i,j) +! pint(i,j)=arrayr42d(i,j) ! enddo ! enddo ! endif ! PBL height using nemsio - if(trim(fieldname) == 'hpbl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) + if(trim(fieldname)=='hpbl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pblh,arrayr42d) do j=jsta,jend do i=ista, iend - pblh(i,j) = arrayr42d(i,j) + pblh(i,j)=arrayr42d(i,j) enddo enddo endif ! frictional velocity - if(trim(fieldname) == 'fricv') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) + if(trim(fieldname)=='fricv') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ustar,arrayr42d) do j=jsta,jend do i=ista, iend - ustar(i,j) = arrayr42d(i,j) + ustar(i,j)=arrayr42d(i,j) enddo enddo endif ! roughness length - if(trim(fieldname) == 'sfcr') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) + if(trim(fieldname)=='sfcr') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,z0,arrayr42d) do j=jsta,jend do i=ista, iend - z0(i,j) = arrayr42d(i,j) + z0(i,j)=arrayr42d(i,j) enddo enddo endif ! sfc exchange coeff - if(trim(fieldname) == 'sfexc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) + if(trim(fieldname)=='sfexc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcexc,arrayr42d) do j=jsta,jend do i=ista, iend sfcexc(i,j)=arrayr42d(i,j) @@ -872,18 +884,18 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! aerodynamic conductance - if(trim(fieldname) == 'acond') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) + if(trim(fieldname)=='acond') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,acond,arrayr42d) do j=jsta,jend do i=ista, iend - acond(i,j) = arrayr42d(i,j) + acond(i,j)=arrayr42d(i,j) enddo enddo endif ! surface potential T - if(trim(fieldname) == 'tmpsfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) + if(trim(fieldname)=='tmpsfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ths) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -894,114 +906,114 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! convective precip in m per physics time step - if(trim(fieldname) == 'cpratb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate) + if(trim(fieldname)=='cpratb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) & - avgcprate(i,j) = arrayr42d(i,j) * dtq2001 + avgcprate(i,j) = arrayr42d(i,j) * (dtq2*0.001) enddo enddo endif ! continuous bucket convective precip in m per physics time step - if(trim(fieldname) =='cprat_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgcprate_cont) + if(trim(fieldname)=='cprat_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgcprate_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgcprate_cont(i,j) = arrayr42d(i,j) * dtq2001 + avgcprate_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! time averaged bucketed precip rate - if(trim(fieldname) == 'prateb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec) + if(trim(fieldname)=='prateb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec(i,j) = arrayr42d(i,j) * dtq2001 + avgprec(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! time averaged continuous precip rate in m per physics time step - if(trim(fieldname) == 'prate_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,arrayr42d,avgprec_cont) + if(trim(fieldname)=='prate_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,arrayr42d,avgprec_cont) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - avgprec_cont(i,j) = arrayr42d(i,j) * dtq2001 + avgprec_cont(i,j) = arrayr42d(i,j) * (dtq2*0.001) endif enddo enddo endif ! precip rate in m per physics time step - if(trim(fieldname) == 'tprcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,prec) + if(trim(fieldname)=='tprcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,prec) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - prec(i,j) = arrayr42d(i,j) * (dtq2001 * 1000./dtp) + prec(i,j) = arrayr42d(i,j) * (dtq2*0.001) * 1000./dtp endif enddo enddo endif ! convective precip rate in m per physics time step - if(trim(fieldname) == 'cnvprcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2001,dtp,arrayr42d,cprate) + if(trim(fieldname)=='cnvprcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,dtq2,dtp,arrayr42d,cprate) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then - cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2001 * 1000./dtp) + cprate(i,j) = max(0.,arrayr42d(i,j)) * (dtq2*0.001) * 1000./dtp endif enddo enddo endif ! inst snow water eqivalent - if(trim(fieldname) == 'weasd') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) + if(trim(fieldname)=='weasd') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sno,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend sno(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) sno(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j)==0.)sno(i,j) = spval enddo enddo endif ! ave snow cover - if(trim(fieldname) == 'snowc_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) + if(trim(fieldname)=='snowc_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snoavg,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend snoavg(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) snoavg(i,j) = spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j) = spval if (snoavg(i,j) /= spval) snoavg(i,j) = snoavg(i,j)/100. enddo enddo endif ! snow depth in mm - if(trim(fieldname) == 'snod') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) + if(trim(fieldname)=='snod') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,si,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend si(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) si(i,j)=spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0 enddo enddo endif ! 2m potential T (computed later) - if(trim(fieldname) == 'tmp2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) + if(trim(fieldname)=='tmp2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,tshltr,arrayr42d) do j=jsta,jend do i=ista, iend tshltr(i,j) = arrayr42d(i,j) @@ -1010,8 +1022,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! surface potential T - if(trim(fieldname) == 'spfh2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) + if(trim(fieldname)=='spfh2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,qshltr,arrayr42d) do j=jsta,jend do i=ista, iend qshltr(i,j) = arrayr42d(i,j) @@ -1020,8 +1032,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! mid day avg albedo in fraction - if(trim(fieldname) == 'albdo_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) + if(trim(fieldname)=='albdo_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgalbedo,arrayr42d) do j=jsta,jend do i=ista, iend avgalbedo(i,j) = arrayr42d(i,j) @@ -1033,8 +1045,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname) == 'tcdc_aveclm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) + if(trim(fieldname)=='tcdc_aveclm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgtcdc,arrayr42d) do j=jsta,jend do i=ista, iend avgtcdc(i,j) = arrayr42d(i,j) @@ -1046,8 +1058,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! maximum snow albedo in fraction - if(trim(fieldname) == 'snoalb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) + if(trim(fieldname)=='snoalb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,mxsnal,arrayr42d) do j=jsta,jend do i=ista, iend mxsnal(i,j) = arrayr42d(i,j) @@ -1059,8 +1071,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave high cloud fraction - if(trim(fieldname) == 'tcdc_avehcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) + if(trim(fieldname)=='tcdc_avehcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfrach,arrayr42d) do j=jsta,jend do i=ista, iend avgcfrach(i,j) = arrayr42d(i,j) @@ -1072,8 +1084,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave low cloud fraction - if(trim(fieldname) == 'tcdc_avelcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) + if(trim(fieldname)=='tcdc_avelcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracl,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracl(i,j) = arrayr42d(i,j) @@ -1085,8 +1097,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ave middle cloud fraction - if(trim(fieldname) == 'tcdc_avemcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) + if(trim(fieldname)=='tcdc_avemcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgcfracm,arrayr42d) do j=jsta,jend do i=ista, iend avgcfracm(i,j) = arrayr42d(i,j) @@ -1098,8 +1110,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst convective cloud fraction - if(trim(fieldname) == 'tcdccnvcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) + if(trim(fieldname)=='tcdccnvcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cnvcfr,arrayr42d) do j=jsta,jend do i=ista, iend cnvcfr(i,j) = arrayr42d(i,j) @@ -1111,8 +1123,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! slope type - if(trim(fieldname) == 'sltyp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) + if(trim(fieldname)=='sltyp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,islope) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1125,8 +1137,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged column cloud fraction - if(trim(fieldname) == 'cnwat') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) + if(trim(fieldname)=='cnwat') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,cmc,arrayr42d,sm) do j=jsta,jend do i=ista, iend cmc(i,j) = arrayr42d(i,j) @@ -1137,8 +1149,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! frozen precip fraction - if(trim(fieldname) == 'cpofp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) + if(trim(fieldname)=='cpofp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,sr) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) /= spval) then @@ -1152,8 +1164,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sea ice skin temperature - if(trim(fieldname) == 'tisfc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) + if(trim(fieldname)=='tisfc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sice,arrayr42d,ti) do j=jsta,jend do i=ista,iend if (arrayr42d(i,j) /= spval) then @@ -1167,8 +1179,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation fraction - if(trim(fieldname) == 'veg') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) + if(trim(fieldname)=='veg') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,vegfrc,arrayr42d,sm) do j=jsta,jend do i=ista, iend vegfrc(i,j) = arrayr42d(i,j) @@ -1183,8 +1195,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,1) = arrayr42d(i,j) @@ -1194,8 +1206,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,2) = arrayr42d(i,j) @@ -1205,8 +1217,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,3) = arrayr42d(i,j) @@ -1216,8 +1228,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! liquid volumetric soil mpisture in fraction - if(trim(fieldname) == 'soill4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) + if(trim(fieldname)=='soill4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sh2o,arrayr42d,sm) do j=jsta,jend do i=ista, iend sh2o(i,j,4) = arrayr42d(i,j) @@ -1227,8 +1239,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,1) = arrayr42d(i,j) @@ -1238,8 +1250,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,2) = arrayr42d(i,j) @@ -1249,8 +1261,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,3) = arrayr42d(i,j) @@ -1260,8 +1272,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! volumetric soil moisture - if(trim(fieldname) == 'soilw4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) + if(trim(fieldname)=='soilw4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smc,arrayr42d,sm) do j=jsta,jend do i=ista, iend smc(i,j,4) = arrayr42d(i,j) @@ -1271,8 +1283,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt1') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt1') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,1) = arrayr42d(i,j) @@ -1283,8 +1295,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt2') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt2') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,2) = arrayr42d(i,j) @@ -1295,8 +1307,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt3') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt3') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,3) = arrayr42d(i,j) @@ -1307,8 +1319,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil temperature - if(trim(fieldname) == 'soilt4') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) + if(trim(fieldname)=='soilt4') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,stc,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend stc(i,j,4) = arrayr42d(i,j) @@ -1320,7 +1332,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged incoming sfc longwave if(trim(fieldname)=='dlwrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwin,arrayr42d) do j=jsta,jend do i=ista, iend alwin(i,j) = arrayr42d(i,j) @@ -1329,8 +1341,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc longwave - if(trim(fieldname) == 'dlwrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) + if(trim(fieldname)=='dlwrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rlwin,arrayr42d) do j=jsta,jend do i=ista, iend rlwin(i,j) = arrayr42d(i,j) @@ -1339,8 +1351,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc longwave, CLDRAD puts a minus sign - if(trim(fieldname) == 'ulwrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) + if(trim(fieldname)=='ulwrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,alwout,arrayr42d) do j=jsta,jend do i=ista, iend alwout(i,j) = arrayr42d(i,j) @@ -1350,8 +1362,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc longwave - if(trim(fieldname) == 'ulwrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) + if(trim(fieldname)=='ulwrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,radot,arrayr42d) do j=jsta,jend do i=ista, iend radot(i,j) = arrayr42d(i,j) @@ -1360,8 +1372,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing model top longwave - if(trim(fieldname) == 'ulwrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) + if(trim(fieldname)=='ulwrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoa,arrayr42d) do j=jsta,jend do i=ista, iend alwtoa(i,j) = arrayr42d(i,j) @@ -1370,8 +1382,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc shortwave - if(trim(fieldname) == 'dswrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) + if(trim(fieldname)=='dswrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswin,arrayr42d) do j=jsta,jend do i=ista, iend aswin(i,j) = arrayr42d(i,j) @@ -1380,8 +1392,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst incoming sfc shortwave - if(trim(fieldname) == 'dswrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) + if(trim(fieldname)=='dswrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswin,arrayr42d) do j=jsta,jend do i=ista, iend rswin(i,j) = arrayr42d(i,j) @@ -1390,8 +1402,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc uv-b - if(trim(fieldname) == 'duvb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) + if(trim(fieldname)=='duvb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbin,arrayr42d) do j=jsta,jend do i=ista, iend auvbin(i,j) = arrayr42d(i,j) @@ -1400,8 +1412,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged incoming sfc clear sky uv-b - if(trim(fieldname) == 'cduvb_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) + if(trim(fieldname)=='cduvb_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,auvbinc,arrayr42d) do j=jsta,jend do i=ista, iend auvbinc(i,j) = arrayr42d(i,j) @@ -1410,8 +1422,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged outgoing sfc shortwave,CLDRAD puts a minus sign - if(trim(fieldname) == 'uswrf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) + if(trim(fieldname)=='uswrf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,aswout,arrayr42d) do j=jsta,jend do i=ista, iend aswout(i,j) = arrayr42d(i,j) @@ -1421,8 +1433,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst outgoing sfc shortwave - if(trim(fieldname) == 'uswrf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) + if(trim(fieldname)=='uswrf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,rswout,arrayr42d) do j=jsta,jend do i=ista, iend rswout(i,j) = arrayr42d(i,j) @@ -1431,8 +1443,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged model top incoming shortwave - if(trim(fieldname) == 'dswrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) + if(trim(fieldname)=='dswrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswintoa,arrayr42d) do j=jsta,jend do i=ista, iend aswintoa(i,j) = arrayr42d(i,j) @@ -1441,8 +1453,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ime averaged model top outgoing shortwave - if(trim(fieldname) == 'uswrf_avetoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) + if(trim(fieldname)=='uswrf_avetoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoa,arrayr42d) do j=jsta,jend do i=ista, iend aswtoa(i,j) = arrayr42d(i,j) @@ -1452,8 +1464,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface sensible heat flux, multiplied by -1 because ! wrf model fluxhas reversed sign convention using gfsio - if(trim(fieldname) == 'shtfl_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) + if(trim(fieldname)=='shtfl_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfcshx,arrayr42d) do j=jsta,jend do i=ista, iend sfcshx(i,j) = arrayr42d(i,j) @@ -1463,8 +1475,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface sensible heat flux - if(trim(fieldname) == 'shtfl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) + if(trim(fieldname)=='shtfl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,twbs,arrayr42d) do j=jsta,jend do i=ista, iend twbs(i,j) = arrayr42d(i,j) @@ -1475,8 +1487,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & ! time averaged surface latent heat flux, multiplied by -1 because ! wrf model flux has reversed sign vonvention using gfsio - if(trim(fieldname) == 'lhtfl_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) + if(trim(fieldname)=='lhtfl_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,sfclhx,arrayr42d) do j=jsta,jend do i=ista, iend sfclhx(i,j) = arrayr42d(i,j) @@ -1486,8 +1498,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst surface latent heat flux - if(trim(fieldname) == 'lhtfl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) + if(trim(fieldname)=='lhtfl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,qwbs,arrayr42d) do j=jsta,jend do i=ista, iend qwbs(i,j) = arrayr42d(i,j) @@ -1497,30 +1509,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged ground heat flux - if(trim(fieldname) == 'gflux_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) + if(trim(fieldname)=='gflux_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,subshx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend subshx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) subshx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval enddo enddo endif ! inst ground heat flux - if(trim(fieldname) == 'gflux') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) + if(trim(fieldname)=='gflux') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,grnflx,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend grnflx(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) grnflx(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval enddo enddo endif ! time averaged zonal momentum flux - if(trim(fieldname) == 'uflx_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) + if(trim(fieldname)=='uflx_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcux,arrayr42d) do j=jsta,jend do i=ista, iend sfcux(i,j) = arrayr42d(i,j) @@ -1529,8 +1541,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional momentum flux - if(trim(fieldname) == 'vflx_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) + if(trim(fieldname)=='vflx_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,sfcvx,arrayr42d) do j=jsta,jend do i=ista, iend sfcvx(i,j) = arrayr42d(i,j) @@ -1539,8 +1551,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged zonal gravity wave stress - if(trim(fieldname) == 'u-gwd_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) + if(trim(fieldname)=='u-gwd_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtaux,arrayr42d) do j=jsta,jend do i=ista, iend gtaux(i,j) = arrayr42d(i,j) @@ -1549,8 +1561,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged meridional gravity wave stress - if(trim(fieldname) == 'v-gwd_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) + if(trim(fieldname)=='v-gwd_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,gtauy,arrayr42d) do j=jsta,jend do i=ista, iend gtauy(i,j) = arrayr42d(i,j) @@ -1559,30 +1571,30 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged accumulated potential evaporation - if(trim(fieldname) == 'pevpr_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) + if(trim(fieldname)=='pevpr_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgpotevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgpotevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgpotevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval enddo enddo endif ! inst potential evaporation - if(trim(fieldname) == 'pevpr') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) + if(trim(fieldname)=='pevpr') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,potevp,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend potevp(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) potevp(i,j) = spval + if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval enddo enddo endif ! 10 m u - if(trim(fieldname) == 'ugrd10m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) + if(trim(fieldname)=='ugrd10m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,u10,arrayr42d,u10h) do j=jsta,jend do i=ista, iend u10(i,j) = arrayr42d(i,j) @@ -1592,8 +1604,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! 10 m v - if(trim(fieldname) == 'vgrd10m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) + if(trim(fieldname)=='vgrd10m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,v10,arrayr42d,v10h) do j=jsta,jend do i=ista, iend v10(i,j) = arrayr42d(i,j) @@ -1603,8 +1615,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! vegetation type - if(trim(fieldname) == 'vtype') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) + if(trim(fieldname)=='vtype') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,ivgtyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1617,8 +1629,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! soil type - if(trim(fieldname) == 'sotyp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) + if(trim(fieldname)=='sotyp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,arrayr42d,isltyp) do j=jsta,jend do i=ista, iend if (arrayr42d(i,j) < spval) then @@ -1631,8 +1643,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud top pressure - if(trim(fieldname) == 'prescnvclt') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) + if(trim(fieldname)=='prescnvclt') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ptop,arrayr42d) do j=jsta,jend do i=ista, iend ptop(i,j) = arrayr42d(i,j) @@ -1642,8 +1654,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! inst cloud bottom pressure - if(trim(fieldname) == 'prescnvclb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) + if(trim(fieldname)=='prescnvclb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pbot,arrayr42d) do j=jsta,jend do i=ista, iend pbot(i,j) = arrayr42d(i,j) @@ -1653,8 +1665,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top pressure - if(trim(fieldname) == 'pres_avelct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) + if(trim(fieldname)=='pres_avelct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopl,arrayr42d) do j=jsta,jend do i=ista, iend ptopl(i,j) = arrayr42d(i,j) @@ -1663,8 +1675,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud bottom pressure - if(trim(fieldname) == 'pres_avelcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) + if(trim(fieldname)=='pres_avelcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotl,arrayr42d) do j=jsta,jend do i=ista, iend pbotl(i,j) = arrayr42d(i,j) @@ -1673,8 +1685,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged low cloud top temperature - if(trim(fieldname) == 'tmp_avelct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) + if(trim(fieldname)=='tmp_avelct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopl,arrayr42d) do j=jsta,jend do i=ista, iend ttopl(i,j) = arrayr42d(i,j) @@ -1683,8 +1695,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top pressure - if(trim(fieldname) == 'pres_avemct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) + if(trim(fieldname)=='pres_avemct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptopm,arrayr42d) do j=jsta,jend do i=ista, iend ptopm(i,j) = arrayr42d(i,j) @@ -1693,8 +1705,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud bottom pressure - if(trim(fieldname) == 'pres_avemcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) + if(trim(fieldname)=='pres_avemcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pbotm,arrayr42d) do j=jsta,jend do i=ista, iend pbotm(i,j) = arrayr42d(i,j) @@ -1703,8 +1715,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged middle cloud top temperature - if(trim(fieldname) == 'tmp_avemct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) + if(trim(fieldname)=='tmp_avemct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttopm,arrayr42d) do j=jsta,jend do i=ista, iend ttopm(i,j) = arrayr42d(i,j) @@ -1713,8 +1725,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top pressure - if(trim(fieldname) == 'pres_avehct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) + if(trim(fieldname)=='pres_avehct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ptoph,arrayr42d) do j=jsta,jend do i=ista, iend ptoph(i,j) = arrayr42d(i,j) @@ -1723,8 +1735,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud bottom pressure - if(trim(fieldname) == 'pres_avehcb') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) + if(trim(fieldname)=='pres_avehcb') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,pboth,arrayr42d) do j=jsta,jend do i=ista, iend pboth(i,j) = arrayr42d(i,j) @@ -1733,8 +1745,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged high cloud top temperature - if(trim(fieldname) == 'tmp_avehct') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) + if(trim(fieldname)=='tmp_avehct') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,ttoph,arrayr42d) do j=jsta,jend do i=ista, iend ttoph(i,j) = arrayr42d(i,j) @@ -1743,8 +1755,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged boundary layer cloud cover - if(trim(fieldname) == 'tcdc_avebndcl') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) + if(trim(fieldname)=='tcdc_avebndcl') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,pblcfr,arrayr42d) do j=jsta,jend do i=ista, iend pblcfr(i,j) = arrayr42d(i,j) @@ -1754,8 +1766,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! cloud work function - if(trim(fieldname) == 'cwork_aveclm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) + if(trim(fieldname)=='cwork_aveclm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,cldwork,arrayr42d) do j=jsta,jend do i=ista, iend cldwork(i,j) = arrayr42d(i,j) @@ -1764,8 +1776,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! water runoff - if(trim(fieldname) == 'watr_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) + if(trim(fieldname)=='watr_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,runoff,arrayr42d,sm) do j=jsta,jend do i=ista, iend runoff(i,j) = arrayr42d(i,j) @@ -1775,8 +1787,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max temperature - if(trim(fieldname) == 'tmax_max2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) + if(trim(fieldname)=='tmax_max2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxtshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxtshltr(i,j) = arrayr42d(i,j) @@ -1785,8 +1797,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname) == 'tmin_min2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) + if(trim(fieldname)=='tmin_min2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,mintshltr,arrayr42d) do j=jsta,jend do i=ista, iend mintshltr(i,j) = arrayr42d(i,j) @@ -1795,8 +1807,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! ice thickness - if(trim(fieldname) == 'icetk') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) + if(trim(fieldname)=='icetk') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,dzice,arrayr42d) do j=jsta,jend do i=ista, iend dzice(i,j) = arrayr42d(i,j) @@ -1805,8 +1817,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! wilting point - if(trim(fieldname) == 'wilt') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) + if(trim(fieldname)=='wilt') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend, spval,smcwlt,arrayr42d,sm) do j=jsta,jend do i=ista, iend smcwlt(i,j) = arrayr42d(i,j) @@ -1816,8 +1828,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! sunshine duration - if(trim(fieldname) == 'sunsd_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) + if(trim(fieldname)=='sunsd_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,suntime,arrayr42d) do j=jsta,jend do i=ista, iend suntime(i,j) = arrayr42d(i,j) @@ -1826,8 +1838,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! field capacity - if(trim(fieldname) == 'fldcp') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) + if(trim(fieldname)=='fldcp') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,fieldcapa,arrayr42d,sm) do j=jsta,jend do i=ista, iend fieldcapa(i,j) = arrayr42d(i,j) @@ -1837,8 +1849,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible beam downward solar flux - if(trim(fieldname) == 'vbdsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) + if(trim(fieldname)=='vbdsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend avisbeamswin(i,j) = arrayr42d(i,j) @@ -1847,8 +1859,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface visible diffuse downward solar flux - if(trim(fieldname) == 'vddsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) + if(trim(fieldname)=='vddsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,avisdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend avisdiffswin(i,j) = arrayr42d(i,j) @@ -1857,8 +1869,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR beam downward solar flux - if(trim(fieldname) == 'nbdsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) + if(trim(fieldname)=='nbdsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airbeamswin,arrayr42d) do j=jsta,jend do i=ista, iend airbeamswin(i,j) = arrayr42d(i,j) @@ -1867,8 +1879,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface near IR diffuse downward solar flux - if(trim(fieldname) == 'nddsf_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) + if(trim(fieldname)=='nddsf_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,airdiffswin,arrayr42d) do j=jsta,jend do i=ista, iend airdiffswin(i,j) = arrayr42d(i,j) @@ -1877,8 +1889,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing LW - if(trim(fieldname) == 'csulf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) + if(trim(fieldname)=='csulf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwoutc,arrayr42d) do j=jsta,jend do i=ista, iend alwoutc(i,j) = arrayr42d(i,j) @@ -1887,8 +1899,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing LW - if(trim(fieldname) == 'csulftoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) + if(trim(fieldname)=='csulftoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwtoac,arrayr42d) do j=jsta,jend do i=ista, iend alwtoac(i,j) = arrayr42d(i,j) @@ -1897,8 +1909,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky outgoing SW - if(trim(fieldname) == 'csusf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) + if(trim(fieldname)=='csusf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswoutc,arrayr42d) do j=jsta,jend do i=ista, iend aswoutc(i,j) = arrayr42d(i,j) @@ -1907,8 +1919,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged TOA clear sky outgoing SW - if(trim(fieldname) == 'csusftoa') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) + if(trim(fieldname)=='csusftoa') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswtoac,arrayr42d) do j=jsta,jend do i=ista, iend aswtoac(i,j) = arrayr42d(i,j) @@ -1917,8 +1929,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming LW - if(trim(fieldname) == 'csdlf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) + if(trim(fieldname)=='csdlf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,alwinc,arrayr42d) do j=jsta,jend do i=ista, iend alwinc(i,j) = arrayr42d(i,j) @@ -1927,8 +1939,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! time averaged surface clear sky incoming SW - if(trim(fieldname) == 'csdsf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) + if(trim(fieldname)=='csdsf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,aswinc,arrayr42d) do j=jsta,jend do i=ista, iend aswinc(i,j) = arrayr42d(i,j) @@ -1937,8 +1949,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter max specific humidity - if(trim(fieldname) == 'spfhmax_max2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) + if(trim(fieldname)=='spfhmax_max2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,maxqshltr,arrayr42d) do j=jsta,jend do i=ista, iend maxqshltr(i,j) = arrayr42d(i,j) @@ -1947,8 +1959,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! shelter min temperature - if(trim(fieldname) == 'spfhmin_min2m') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) + if(trim(fieldname)=='spfhmin_min2m') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,minqshltr,arrayr42d) do j=jsta,jend do i=ista, iend minqshltr(i,j) = arrayr42d(i,j) @@ -1957,8 +1969,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! storm runoffs - if(trim(fieldname) == 'ssrun_acc') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) + if(trim(fieldname)=='ssrun_acc') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,ssroff,arrayr42d,sm) do j=jsta,jend do i=ista, iend ssroff(i,j) = arrayr42d(i,j) @@ -1968,8 +1980,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! direct soil evaporation - if(trim(fieldname) == 'evbs_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) + if(trim(fieldname)=='evbs_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgedir,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgedir(i,j) = arrayr42d(i,j) @@ -1979,8 +1991,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! canopy water evap - if(trim(fieldname) == 'evcw_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) + if(trim(fieldname)=='evcw_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgecan,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgecan(i,j) = arrayr42d(i,j) @@ -1990,8 +2002,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! plant transpiration - if(trim(fieldname) == 'trans_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) + if(trim(fieldname)=='trans_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgetrans,arrayr42d,sm) do j=jsta,jend do i=ista, iend avgetrans(i,j) = arrayr42d(i,j) @@ -2001,19 +2013,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow sublimation - if(trim(fieldname) == 'sbsno_ave') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) + if(trim(fieldname)=='sbsno_ave') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,avgesnow,arrayr42d,sm,sice) do j=jsta,jend do i=ista, iend avgesnow(i,j) = arrayr42d(i,j) - if (sm(i,j) == 1.0 .and. sice(i,j) == 0.) avgesnow(i,j) = spval + if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval enddo enddo endif ! total soil moisture - if(trim(fieldname) == 'soilm') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) + if(trim(fieldname)=='soilm') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,smstot,arrayr42d,sm) do j=jsta,jend do i=ista, iend smstot(i,j) = arrayr42d(i,j) @@ -2023,8 +2035,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! snow phase change heat flux - if(trim(fieldname) == 'snohf') then -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) + if(trim(fieldname)=='snohf') then + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,spval,snopcx,arrayr42d,sm) do j=jsta,jend do i=ista, iend snopcx(i,j) = arrayr42d(i,j) @@ -2034,17 +2046,19 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! else if (fieldDimCount > gridDimCount) then - else if (fieldDimCount == 3) then + else if (fieldDimCount ==3) then if (typekind == ESMF_TYPEKIND_R4) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr43d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out else if (typekind == ESMF_TYPEKIND_R8) then call ESMF_FieldGet(fcstField(n), localDe=0, farrayPtr=arrayr83d, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, file=__FILE__)) return ! bail out allocate(arrayr43d(ista:iend,jsta:jend,kstart:kend)) arrayr43d = 0. do k=kstart,kend -!$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) + !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,k,arrayr43d,arrayr83d) do j=jsta,jend do i=ista,iend arrayr43d(i,j,k) = arrayr83d(i,j,k) @@ -2054,8 +2068,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level T - if(trim(fieldname) == 'tmp') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) + if(trim(fieldname)=='tmp') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,t,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend @@ -2065,7 +2079,7 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo !! sig4 -!$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) + !$omp parallel do default(none) private(i,j,tlmh) shared(lm,jsta,jend,ista,iend,t,sigt4) do j=jsta,jend do i=ista, iend tlmh = t(i,j,lm) * t(i,j,lm) @@ -2075,237 +2089,172 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level spfh - if(trim(fieldname) == 'spfh') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) + if(trim(fieldname)=='spfh') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q(i,j,l) = arrayr43d(i,j,l) + q(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level u wind - if(trim(fieldname) == 'ugrd') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) + if(trim(fieldname)=='ugrd') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,uh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - uh(i,j,l) = arrayr43d(i,j,l) + uh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level v wind - if(trim(fieldname) == 'vgrd') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) + if(trim(fieldname)=='vgrd') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,vh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - vh(i,j,l) = arrayr43d(i,j,l) + vh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level pressure thinkness - if(trim(fieldname) == 'dpres') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) + if(trim(fieldname)=='dpres') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,dpres,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - dpres(i,j,l) = arrayr43d(i,j,l) + dpres(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level gh thinkness, model output negative delz - if(trim(fieldname) == 'delz') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) + if(trim(fieldname)=='delz') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,zint,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - zint(i,j,l) = -arrayr43d(i,j,l) + zint(i,j,l)=-1.*arrayr43d(i,j,l) enddo enddo enddo endif ! model level w - if(trim(fieldname) == 'dzdt') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) + if(trim(fieldname)=='dzdt') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,wh,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - wh(i,j,l) = arrayr43d(i,j,l) + wh(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ozone mixing ratio - if(trim(fieldname) == 'o3mr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) + if(trim(fieldname)=='o3mr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,o3,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - o3(i,j,l) = arrayr43d(i,j,l) + o3(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif -! for GFDL or MG3 MP -! ------------------ - if (imp_physics == 10 .or. imp_physics == 11) then +! for GFDL MP + if (imp_physics == 11) then ! model level cloud water mixing ratio - if(trim(fieldname) == 'clwmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) + if(trim(fieldname)=='clwmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqw,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqw(i,j,l) = arrayr43d(i,j,l) + qqw(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ice mixing ratio - if(trim(fieldname) == 'icmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) + if(trim(fieldname)=='icmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqi,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqi(i,j,l) = arrayr43d(i,j,l) + qqi(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname) == 'rwmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) + if(trim(fieldname)=='rwmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqr(i,j,l) = arrayr43d(i,j,l) + qqr(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level snow mixing ratio - if(trim(fieldname) == 'snmr') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) + if(trim(fieldname)=='snmr') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqs,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqs(i,j,l) = arrayr43d(i,j,l) + qqs(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level rain water mixing ratio - if(trim(fieldname) == 'grle') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqg(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - endif !gfdlmp or MG3 mp -! for MG3 MP -! ---------- - if (imp_physics == 10) then - ! model level cloud water mixing ratio number concentration - if(trim(fieldname) == 'clwnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnw,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqnw(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level ice mixing ratio number concentration - if(trim(fieldname) == 'icenc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqni,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqni(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level rain water mixing ratio number concentration - if(trim(fieldname) == 'rwnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqnr,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqnr(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - ! model level snow mixing ratio number concentration - if(trim(fieldname) == 'snnc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqns,arrayr43d) + if(trim(fieldname)=='grle') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqg,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - qqns(i,j,l) = arrayr43d(i,j,l) + qqg(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif - - ! model level rain water mixing ratio number concentration - if(trim(fieldname) == 'grlenc') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,qqng,arrayr43d) - do l=1,lm - do j=jsta,jend - do i=ista, iend - qqng(i,j,l) = arrayr43d(i,j,l) - enddo - enddo - enddo - endif - - endif ! for MG3 MP +!gfdlmp + endif ! model level cloud amount - if(trim(fieldname) == 'cld_amt') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) + if(trim(fieldname)=='cld_amt') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,cfr,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - cfr(i,j,l) = arrayr43d(i,j,l) + cfr(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo endif ! model level ref3d - if(trim(fieldname) == 'ref3D') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) + if(trim(fieldname)=='ref3D') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,ref_10cm,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - ref_10cm(i,j,l) = arrayr43d(i,j,l) + ref_10cm(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo @@ -2313,12 +2262,12 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & endif ! model level ref3d - if(trim(fieldname) == 'tke') then -!$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) + if(trim(fieldname)=='tke') then + !$omp parallel do default(none) private(i,j,l) shared(lm,jsta,jend,ista,iend,q2,arrayr43d) do l=1,lm do j=jsta,jend do i=ista, iend - q2(i,j,l) = arrayr43d(i,j,l) + q2(i,j,l)=arrayr43d(i,j,l) enddo enddo enddo @@ -2326,7 +2275,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !3d fields endif - enddo ! end loop ncount_field +! end loop ncount_field + enddo if ( index(trim(wrt_int_state%wrtFB_names(ibdl)),trim(filename_base(1))) > 0) & setvar_atmfile = .true. @@ -2352,33 +2302,46 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,omga,wh,dpres,zint) do j=jsta,jend do i=1,im - omga(i,j,l) = - wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) + omga(i,j,l) = (-1.) * wh(i,j,l) * dpres(i,j,l)/zint(i,j,l) zint(i,j,l) = zint(i,j,l) + zint(i,j,l+1) enddo enddo enddo ! compute pint from top down -!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint,pd,spval) +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,ak5,pint) do j=jsta,jend do i=1,im pint(i,j,1) = ak5(1) - pd(i,j) = spval - enddo - enddo + end do + end do do l=2,lp1 - ll = l - 1 -!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,pint,dpres,pmid) +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pint,dpres) do j=jsta,jend do i=1,im - pint(i,j,l) = pint(i,j,ll) + dpres(i,j,ll) + pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1) + enddo + enddo + end do + !compute pmid from averaged two layer pint - pmid(i,j,ll) = 0.5*(pint(i,j,ll)+pint(i,j,l)) + do l=lm,1,-1 +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,pmid,pint) + do j=jsta,jend + do i=1,im + pmid(i,j,l) = 0.5*(pint(i,j,l)+pint(i,j,l+1)) enddo enddo enddo +!$omp parallel do default(none) private(i,j) shared(jsta,jend,im,spval,pt,pd,pint) + do j=jsta,jend + do i=1,im + pd(i,j) = spval + pint(i,j,1) = pt + end do + end do ! print *,'in setvar, pt=',pt,'ak5(lp1)=', ak5(lp1),'ak5(1)=',ak5(1) ! compute alpint @@ -2386,23 +2349,22 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,alpint,pint) do j=jsta,jend do i=1,im - alpint(i,j,l) = log(pint(i,j,l)) - enddo - enddo - enddo + alpint(i,j,l)=log(pint(i,j,l)) + end do + end do + end do ! compute zmid do l=lm,1,-1 - ll = l + 1 -!$omp parallel do default(none) private(i,j) shared(l,ll,jsta,jend,im,zmid,zint,pmid,alpint) +!$omp parallel do default(none) private(i,j) shared(l,jsta,jend,im,zmid,zint,pmid,alpint) do j=jsta,jend do i=1,im - zmid(i,j,l) = zint(i,j,ll) + (zint(i,j,l)-zint(i,j,ll)) & - * (log(pmid(i,j,l))-alpint(i,j,ll)) & - / (alpint(i,j,l)-alpint(i,j,ll)) - enddo - enddo - enddo + zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* & + (log(pmid(i,j,l))-alpint(i,j,l+1))/ & + (alpint(i,j,l)-alpint(i,j,l+1)) + end do + end do + end do ! print *,'in post_gfs,zmid=',maxval(zmid(1:im,jsta:jend,1)), & ! minval(zmid(1:im,jsta:jend,1)),maxloc(zmid(1:im,jsta:jend,1)), & ! 'zint=',maxval(zint(1:im,jsta:jend,2)),minval(zint(1:im,jsta:jend,1)), & @@ -2428,13 +2390,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & enddo enddo -! compute cwm for gfdlmp or MG3 - if( imp_physics == 10 .or. imp_physics == 11) then +! compute cwm for gfdlmp + if( imp_physics == 11 ) then do l=1,lm !$omp parallel do default(none) private(i,j) shared(l,jsta,jend,ista,iend,cwm,qqg,qqs,qqr,qqi,qqw) do j=jsta,jend do i=ista,iend - cwm(i,j,l) = qqg(i,j,l) + qqs(i,j,l) + qqr(i,j,l) + qqi(i,j,l) + qqw(i,j,l) + cwm(i,j,l)=qqg(i,j,l)+qqs(i,j,l)+qqr(i,j,l)+qqi(i,j,l)+qqw(i,j,l) enddo enddo enddo @@ -2444,8 +2406,8 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & !$omp parallel do default(none) private(i,j) shared(jsta,jend,ista,iend,lm,pshltr,pint,tshltr) do j=jsta,jend do i=ista, iend - pshltr(I,J) = pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) - tshltr(i,j) = tshltr(i,j)*(p1000/pshltr(I,J))**CAPA + pshltr(I,J)=pint(i,j,lm+1)*EXP(-0.068283/tshltr(i,j)) + tshltr(i,j)= tshltr(i,j)*(p1000/pshltr(I,J))**CAPA enddo enddo @@ -2456,13 +2418,13 @@ subroutine set_postvars_gfs(wrt_int_state,mpicomp,setvar_atmfile, & if(ptop(i,j) < spval)then do l=1,lm if(ptop(i,j) <= pmid(i,j,l))then - htop(i,j) = l + htop(i,j)=l exit - endif - enddo - endif - enddo - enddo + end if + end do + end if + end do + end do ! hbot do j=jsta,jend