From 805c62c1a89b867b676a50555dc43f323fe1bf56 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 7 Dec 2021 10:39:05 -0700 Subject: [PATCH 1/5] add single precision code changes from michalakes fork, jm-nrl-32bitfp-24cc09e branch --- physics/calpreciptype.f90 | 77 +++++++++-------- physics/funcphys.f90 | 138 ++++++++++++++++++++++++++----- physics/machine.F | 14 ++-- physics/module_bl_mynn.F90 | 14 ++-- physics/radlw_main.F90 | 10 ++- physics/radsw_main.F90 | 9 +- physics/sfc_diag_post.F90 | 9 +- physics/surface_perturbation.F90 | 2 +- 8 files changed, 197 insertions(+), 76 deletions(-) diff --git a/physics/calpreciptype.f90 b/physics/calpreciptype.f90 index dcc8ed49b..d3fbb253b 100644 --- a/physics/calpreciptype.f90 +++ b/physics/calpreciptype.f90 @@ -26,17 +26,18 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & ! -------------------------------------------------------------------- use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe use physcons + use machine , only : kind_phys !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none ! - real, parameter :: pthresh = 0.0, oneog = 1.0/con_g + real(kind=kind_phys), parameter :: pthresh = 0.0, oneog = 1.0/con_g integer,parameter :: nalg = 5 ! ! declare variables. ! integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1 - real,intent(in) :: xlat(im),xlon(im) - real,intent(in) :: randomno(ix,nrcm) + real(kind=kind_phys),intent(in) :: xlat(im),xlon(im) + real(kind=kind_phys),intent(in) :: randomno(ix,nrcm) real(kind=kind_phys),dimension(im), intent(in) :: prec,tskin real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii @@ -220,8 +221,9 @@ subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & !! This subroutine computes precipitation type using a decision tree approach that uses !! variables such as integrated wet bulb temperatue below freezing and lowest layer !! temperature (Baldwin et al. 1994 \cite baldwin_et_al_1994) - subroutine calwxt(lm,lp1,t,q,pmid,pint, & - d608,rog,epsq,zint,iwx,twet) + subroutine calwxt(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,iwx,twet) + use machine , only : kind_phys ! ! file: calwxt.f ! written: 11 november 1993, michael baldwin @@ -247,10 +249,10 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! t,q,pmid,htm,lmh,zint ! integer,intent(in) :: lm,lp1 - real,dimension(lm),intent(in) :: t,q,pmid,twet - real,dimension(lp1),intent(in) :: zint,pint + real(kind=kind_phys),dimension(lm),intent(in) :: t,q,pmid,twet + real(kind=kind_phys),dimension(lp1),intent(in) :: zint,pint integer,intent(out) :: iwx - real,intent(in) :: d608,rog,epsq + real(kind=kind_phys),intent(in) :: d608,rog,epsq ! output: @@ -264,10 +266,10 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! ! internal: ! -! real, allocatable :: twet(:) - real, parameter :: d00=0.0 +! real(kind=kind_phys), allocatable :: twet(:) + real(kind=kind_phys), parameter :: d00=0.0 integer karr,licee - real tcold,twarm + real(kind=kind_phys) tcold,twarm ! subroutines called: ! wetbulb @@ -282,7 +284,7 @@ subroutine calwxt(lm,lp1,t,q,pmid,pint, & ! integer l,lice,iwrml,ifrzl - real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & + real(kind=kind_phys) psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & surfw,surfc,dzkl,area1,pintk1,pintk2,pm150,pkl,tkl,qkl ! allocate ( twet(lm) ) @@ -486,27 +488,28 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! use params_mod ! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use machine , only : kind_phys implicit none ! - real,parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & + real(kind=kind_phys),parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & & emelt=0.045,rlim=0.04,slim=0.85 - real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now + real(kind=kind_phys),parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now ! integer*4 i, k1, lll, k2, toodry ! - real xxx ,mye, icefrac + real(kind=kind_phys) xxx ,mye, icefrac integer, intent(in) :: lm,lp1 - real,dimension(lm), intent(in) :: t,q,pmid,rh,td - real,dimension(lp1),intent(in) :: pint + real(kind=kind_phys),dimension(lm), intent(in) :: t,q,pmid,rh,td + real(kind=kind_phys),dimension(lp1),intent(in) :: pint integer, intent(out) :: ptyp ! - real,dimension(lm) :: tq,pq,rhq,twq + real(kind=kind_phys),dimension(lm) :: tq,pq,rhq,twq ! integer j,l,lev,ii - real rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & + real(kind=kind_phys) rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & rhavg,dtavg,dpk,ptw,pbot -! real b,qtmp,rate,qc - real,external :: xmytw +! real(kind=kind_phys) b,qtmp,rate,qc +! real(kind=kind_phys),external :: xmytw (now inside the module) ! ! initialize. icefrac = -9999. @@ -521,7 +524,7 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) ! causing problems later in this subroutine ! qtmp=max(h1m12,q(l)) ! rhqtmp(lev)=qtmp/qc - rhq(lev) = rh(l) + rhq(lev) = rh(l) pq(lev) = pmid(l) * 0.01 tq(lev) = t(l) enddo @@ -753,10 +756,11 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) !-------------------------------------------------------------------------- function xmytw(t,td,p) ! + use machine , only : kind_phys implicit none ! integer*4 cflag, l - real f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & + real(kind=kind_phys) f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & & de, xmytw data f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ ! @@ -877,19 +881,20 @@ function xmytw(t,td,p) !! \cite bourgouin_2000. !of aes (canada) 1992 subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) + use machine , only : kind_phys implicit none ! ! input: integer,intent(in) :: lm,lp1 - real,intent(in) :: g,rn(2) - real,intent(in), dimension(lm) :: t, q, pmid - real,intent(in), dimension(lp1) :: pint, zint + real(kind=kind_phys),intent(in) :: g,rn(2) + real(kind=kind_phys),intent(in), dimension(lm) :: t, q, pmid + real(kind=kind_phys),intent(in), dimension(lp1) :: pint, zint ! ! output: integer, intent(out) :: ptype ! integer ifrzl,iwrml,l,lhiwrm - real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 + real(kind=kind_phys) pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 ! ! initialize weather type array to zero (ie, off). ! we do this since we want ptype to represent the @@ -1076,6 +1081,7 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! use params_mod ! use ctlblk_mod !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use machine , only : kind_phys implicit none ! ! list of variables needed @@ -1087,9 +1093,9 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & ! t,q,pmid,htm,lmh,zint integer,intent(in) :: lm,lp1 - real,dimension(lm),intent(in) :: t,q,pmid,twet - real,dimension(lp1),intent(in) :: pint,zint - real,intent(in) :: d608,rog,epsq + real(kind=kind_phys),dimension(lm),intent(in) :: t,q,pmid,twet + real(kind=kind_phys),dimension(lp1),intent(in) :: pint,zint + real(kind=kind_phys),intent(in) :: d608,rog,epsq ! output: ! iwx - instantaneous weather type. ! acts like a 4 bit binary @@ -1101,12 +1107,12 @@ subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & integer, intent(out) :: iwx ! internal: ! - real, parameter :: d00=0.0 + real(kind=kind_phys), parameter :: d00=0.0 integer karr,licee - real tcold,twarm + real(kind=kind_phys) tcold,twarm ! integer l,lmhk,lice,iwrml,ifrzl - real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & + real(kind=kind_phys) psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & surfw,surfc,dzkl,pintk1,pintk2,pm150,qkl,tkl,pkl,area0,areap0 ! subroutines called: @@ -1316,14 +1322,15 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & ! algorithms and sums them up to give a dominant type ! !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use machine , only : kind_phys implicit none ! ! input: integer,intent(in) :: nalg - real,intent(out) :: doms,domr,domzr,domip + real(kind=kind_phys),intent(out) :: doms,domr,domzr,domip integer,dimension(nalg),intent(in) :: rain,snow,sleet,freezr integer l - real totsn,totip,totr,totzr + real(kind=kind_phys) totsn,totip,totr,totzr !-------------------------------------------------------------------------- ! print* , 'into dominant' domr = 0. diff --git a/physics/funcphys.f90 b/physics/funcphys.f90 index 8cb4b1b15..3e81a0d5a 100644 --- a/physics/funcphys.f90 +++ b/physics/funcphys.f90 @@ -260,7 +260,7 @@ module funcphys ! Language: Fortran 90 ! !$$$ - use machine,only:kind_phys + use machine,only:kind_phys,r8=>kind_dbl_prec,r4=>kind_sngl_prec use physcons implicit none private @@ -308,6 +308,13 @@ module funcphys public grkap,frkap,frkapq,frkapx public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx public gfuncphys + + interface fpvsl + module procedure fpvsl_r4, fpvsl_r8 + end interface fpvsl + interface fpvsi + module procedure fpvsi_r4, fpvsi_r8 + end interface fpvsi contains !------------------------------------------------------------------------------- !> This subroutine computes saturation vapor pressure table as a function of @@ -364,7 +371,8 @@ subroutine gpvsl !! in gpvsl(). See documentation for fpvslx() for details. Input values !! outside table range are reset to table extrema. !>\author N phillips - elemental function fpvsl(t) + + elemental function fpvsl_r4(t) !$$$ Subprogram Documentation Block ! ! Subprogram: fpvsl Compute saturation vapor pressure over liquid @@ -396,16 +404,62 @@ elemental function fpvsl(t) ! !$$$ implicit none - real(krealfp) fpvsl - real(krealfp),intent(in):: t + real(r4) fpvsl_r4 + real(r4),intent(in):: t integer jx - real(krealfp) xj + real(r4) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) - jx=min(xj,nxpvsl-1._krealfp) - fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) + xj=min(max(c1xpvsl+c2xpvsl*t,1._r4),real(nxpvsl,r4)) + jx=min(xj,nxpvsl-1._r4) + fpvsl_r4=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function + end function fpvsl_r4 + + elemental function fpvsl_r8(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsl Compute saturation vapor pressure over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvsl. See documentation for fpvslx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvsl is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: pvsl=fpvsl(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsl Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(r8) fpvsl_r8 + real(r8),intent(in):: t + integer jx + real(r8) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsl+c2xpvsl*t,1._r8),real(nxpvsl,r8)) + jx=min(xj,nxpvsl-1._r8) + fpvsl_r8=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function fpvsl_r8 + + + !------------------------------------------------------------------------------- !> This function computes saturation vapor pressure from the temperature. !! A quadratic interpolation is done between values in a lookup table @@ -576,7 +630,8 @@ subroutine gpvsi !! computed in gpvsi(). See documentation for fpvsix() for details. !! Input values outside table range are reset to table extrema. !>\author N Phillips - elemental function fpvsi(t) + + elemental function fpvsi_r4(t) !$$$ Subprogram Documentation Block ! ! Subprogram: fpvsi Compute saturation vapor pressure over ice @@ -609,16 +664,61 @@ elemental function fpvsi(t) ! !$$$ implicit none - real(krealfp) fpvsi - real(krealfp),intent(in):: t + real(r4) fpvsi_r4 + real(r4),intent(in):: t integer jx - real(krealfp) xj + real(r4) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) - jx=min(xj,nxpvsi-1._krealfp) - fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) + xj=min(max(c1xpvsi+c2xpvsi*t,1._r4),real(nxpvsi,r4)) + jx=min(xj,nxpvsi-1._r4) + fpvsi_r4=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function + end function fpvsi_r4 + + elemental function fpvsi_r8(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsi Compute saturation vapor pressure over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvsi. See documentation for fpvsix for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvsi is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvsi=fpvsi(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsi Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(r8) fpvsi_r8 + real(r8),intent(in):: t + integer jx + real(r8) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsi+c2xpvsi*t,1._r8),real(nxpvsi,r8)) + jx=min(xj,nxpvsi-1._r8) + fpvsi_r8=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function fpvsi_r8 + !------------------------------------------------------------------------------- !> This function computes saturation vapor pressure from the temperature. !! A quadratic interpolation is done between values in a lookup table @@ -2375,7 +2475,7 @@ elemental subroutine stmaq(the,pk,tma,qma) !>\param[in] pk real, pressure over 1e5 Pa to the kappa power !>\param[out] tma real, parcel temperature in Kelvin !>\param[out] qma real, parcel specific humidity in kg/kg - elemental subroutine stmax(the,pk,tma,qma) + subroutine stmax(the,pk,tma,qma) !$$$ Subprogram Documentation Block ! ! Subprogram: stmax Compute moist adiabat temperature @@ -2443,7 +2543,7 @@ elemental subroutine stmax(the,pk,tma,qma) !>\param[in] pk real, pressure over 1e5 Pa to the kappa power !>\param[out] tma real, parcel temperature in Kelvin !>\param[out] qma real, parcel specific humidity in kg/kg - elemental subroutine stmaxg(tg,the,pk,tma,qma) + subroutine stmaxg(tg,the,pk,tma,qma) !$$$ Subprogram Documentation Block ! ! Subprogram: stmaxg Compute moist adiabat temperature diff --git a/physics/machine.F b/physics/machine.F index 896b665da..2ee7fb865 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -9,11 +9,12 @@ module machine #ifndef SINGLE_PREC integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & &, kind_evod = 8, kind_dbl_prec = 8 & -#ifdef __PGI + &, kind_sngl_prec = 4 +# ifdef __PGI &, kind_qdt_prec = 8 & -#else +# else &, kind_qdt_prec = 16 & -#endif +# endif &, kind_rad = 8 & &, kind_phys = 8 ,kind_taum=8 & &, kind_grid = 8 & @@ -24,11 +25,12 @@ module machine #else integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & &, kind_evod = 4, kind_dbl_prec = 8 & -#ifdef __PGI + &, kind_sngl_prec = 4 +# ifdef __PGI &, kind_qdt_prec = 8 & -#else +# else &, kind_qdt_prec = 16 & -#endif +# endif &, kind_rad = 4 & &, kind_phys = 4 ,kind_taum=4 & &, kind_grid = 4 & diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index d691de909..ff9574a27 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -142,6 +142,7 @@ MODULE module_bl_mynn & XLF => con_hfus, & & EP_1 => con_fvirt, & & EP_2 => con_eps + use machine, only : kind_phys IMPLICIT NONE @@ -1470,8 +1471,11 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos lb1(iz) = min(dlu(iz),dld(iz)) !minimum !JOE-fight floating point errors +#ifdef SINGLE_PREC + !JM: keep up the fight, JOE dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) +#endif lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average @@ -2692,7 +2696,7 @@ SUBROUTINE mym_condensation (kts,kte, & !CLOUD WATER AND ICE IF (q1k < 0.) THEN !unstaurated - ql_water = sgm(k)*EXP(1.2*q1k-1) + ql_water = sgm(k)*EXP(1.2*q1k-1.) ql_ice = sgm(k)*EXP(1.2*q1k-1.) !Reduce ice mixing ratios in the upper troposphere ! low_weight = MIN(MAX(p(k)-40000.0, 0.0),40000.0)/40000.0 @@ -6723,15 +6727,15 @@ FUNCTION qsat_blend(t, P, waterice) IF ((t .GE. 273.16) .OR. (wrt .EQ. 'w')) THEN ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) - qsat_blend = 0.622*ESL/(P-ESL) + qsat_blend = 0.622*ESL/max((P-ESL),1.0E-7_kind_phys) ELSE IF (t .LE. 253.) THEN ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - qsat_blend = 0.622*ESI/(P-ESI) + qsat_blend = 0.622*ESI/max((P-ESI),1.0E-7_kind_phys) ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) - RSLF = 0.622*ESL/(P-ESL) - RSIF = 0.622*ESI/(P-ESI) + RSLF = 0.622*ESL/max((P-ESL),1.0E-7_kind_phys) + RSIF = 0.622*ESI/max((P-ESI),1.0E-7_kind_phys) chi = (273.16-t)/20.16 qsat_blend = (1.-chi)*RSLF + chi*RSIF END IF diff --git a/physics/radlw_main.F90 b/physics/radlw_main.F90 index 89609c283..b6e41b094 100644 --- a/physics/radlw_main.F90 +++ b/physics/radlw_main.F90 @@ -286,7 +286,8 @@ module rrtmg_lw & random_stat !mz use machine, only : kind_phys, & - & im => kind_io4, rb => kind_phys + & im => kind_io4, rb => kind_phys, & + & kind_dbl_prec use module_radlw_parameters ! @@ -2071,9 +2072,10 @@ subroutine mcica_subcol & logical, dimension(ngptlw,nlay), intent(out) :: lcloudy ! --- locals: - real (kind=kind_phys) :: cdfunc(ngptlw,nlay), rand1d(ngptlw), & - & rand2d(nlay*ngptlw), tem1, fac_lcf(nlay), & + real (kind=kind_phys) :: cdfunc(ngptlw,nlay), & + & tem1, fac_lcf(nlay), & & cdfun2(ngptlw,nlay) + real (kind=kind_dbl_prec) rand2d(nlay*ngptlw), rand1d(ngptlw) type (random_stat) :: stat ! for thread safe random generator @@ -8968,4 +8970,4 @@ end subroutine cldprmc !........................................!$ end module rrtmg_lw !$ -!========================================!$ \ No newline at end of file +!========================================!$ diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 0f5a8b110..32097d868 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -310,7 +310,7 @@ module rrtmg_sw use physcons, only : con_g, con_cp, con_avgd, con_amd, & & con_amw, con_amo3 use machine, only : rb => kind_phys, im => kind_io4, & - & kind_phys + & kind_phys, kind_dbl_prec use module_radsw_parameters use mersenne_twister, only : random_setseed, random_number, & @@ -1733,6 +1733,10 @@ subroutine rswinit & tfn = float(i) / float(NTBMX-i) tau = bpade * tfn exp_tbl(i) = exp( -tau ) +#ifdef SINGLE_PREC + ! from WRF version, prevents zero at single prec + if (exp_tbl(i) .le. expeps) exp_tbl(i) = expeps +#endif enddo return @@ -2213,8 +2217,9 @@ subroutine mcica_subcol & ! --- locals: real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & - & rand2d(nlay*ngptsw), rand1d(ngptsw), fac_lcf(nlay), & + & fac_lcf(nlay), & & cdfun2(nlay,ngptsw) + real (kind=kind_dbl_prec) :: rand2d(nlay*ngptsw), rand1d(ngptsw) type (random_stat) :: stat ! for thread safe random generator diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 6f14fe93d..26f4f1ba8 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -19,7 +19,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, & wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) - use machine, only: kind_phys + use machine, only: kind_phys, kind_dbl_prec implicit none @@ -35,7 +35,7 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con integer, intent(out) :: errflg integer :: i - real(kind=kind_phys) :: tem + real(kind=kind_dbl_prec) :: tem ! made dbl prec always, JM 20211104 ! Initialize CCPP error handling variables errmsg = '' @@ -57,8 +57,9 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con v10mmax(i) = v10m(i) endif ! Compute dew point, first using vapor pressure - tem = max(pgr(i) * q2m(i) / ( con_eps - con_epsm1 *q2m(i)), 1.e-8) - dpt2m(i) = 243.5 / ( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + tem = max(pgr(i) * q2m(i) / ( con_eps - con_epsm1 *q2m(i)), 1.d-8) + dpt2m(i) = 243.5_kind_dbl_prec / & + ( ( 17.67_kind_dbl_prec / log(tem/611.2_kind_dbl_prec) ) - 1.) + 273.14 enddo endif diff --git a/physics/surface_perturbation.F90 b/physics/surface_perturbation.F90 index e0429a5fc..7ddbe5279 100644 --- a/physics/surface_perturbation.F90 +++ b/physics/surface_perturbation.F90 @@ -48,7 +48,7 @@ subroutine cdfnor(z,cdfz) cdfz = 0.5 else x = 0.5*z*z - call cdfgam(x,0.5,del,iflag, cdfx) + call cdfgam(x,0.5_kind_phys,del,iflag, cdfx) if (iflag.ne.0) return if (z.gt.0.0) then cdfz = 0.5+0.5*cdfx From 527e1b976bd74dc0214a13f91f804ec2334d862c Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 2 May 2022 22:11:42 +0000 Subject: [PATCH 2/5] Pass -DCCPP_SINGLE_PRECISION from cmake to -DSINGLE_PREC in cpp --- CMakeLists.txt | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 60531b9a5..691b283f2 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -29,6 +29,13 @@ if(CMAKE_BUILD_TYPE STREQUAL "Debug") add_definitions(-DDEBUG) endif() +if(CCPP_SINGLE_PREC) + message(STATUS "CCPP Single Precision Mode activated.") + add_definitions(SINGLE_PREC) +else(CCPP_SINGLE_PREC) + message(STATUS "CCPP Double Precision Mode activated.") +endif(CCPP_SINGLE_PREC) + #------------------------------------------------------------------------------ # Request a static build option(BUILD_SHARED_LIBS "Build a shared library" OFF) From 6871a936a9df8054fa2b4b34c6e52ad5d5cce738 Mon Sep 17 00:00:00 2001 From: Samuel Trahan Date: Wed, 4 May 2022 17:32:24 +0000 Subject: [PATCH 3/5] Changes needed for 32-bit physics --- CMakeLists.txt | 7 ---- physics/GFS_rrtmgp_cloud_overlap.F90 | 4 +-- physics/GFS_suite_interstitial_4.F90 | 10 +++--- physics/calpreciptype.f90 | 9 ++++- physics/machine.F | 2 +- physics/maximum_hourly_diagnostics.F90 | 14 ++++---- physics/mersenne_twister.f | 46 ++++++++++++++------------ physics/module_sf_mynn.F90 | 4 +-- physics/module_sf_noahmplsm.f90 | 4 +-- physics/module_sf_ruclsm.F90 | 5 +-- physics/module_soil_pre.F90 | 24 ++++++++------ physics/radiation_gases.f | 2 +- physics/radlw_main.meta | 2 +- physics/radsw_main.F90 | 2 +- physics/radsw_main.meta | 2 +- 15 files changed, 72 insertions(+), 65 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 691b283f2..60531b9a5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -29,13 +29,6 @@ if(CMAKE_BUILD_TYPE STREQUAL "Debug") add_definitions(-DDEBUG) endif() -if(CCPP_SINGLE_PREC) - message(STATUS "CCPP Single Precision Mode activated.") - add_definitions(SINGLE_PREC) -else(CCPP_SINGLE_PREC) - message(STATUS "CCPP Double Precision Mode activated.") -endif(CCPP_SINGLE_PREC) - #------------------------------------------------------------------------------ # Request a static build option(BUILD_SHARED_LIBS "Build a shared library" OFF) diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index 13794641b..c1a6c4763 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -99,7 +99,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! Cloud overlap parameter ! if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001, de_lgth, cld_frac, cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001_kind_phys, de_lgth, cld_frac, cloud_overlap_param) else de_lgth(:) = 0. cloud_overlap_param(:,:) = 0. @@ -110,7 +110,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001_kind_phys, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) else de_lgth(:) = 0. cnv_cloud_overlap_param(:,:) = 0. diff --git a/physics/GFS_suite_interstitial_4.F90 b/physics/GFS_suite_interstitial_4.F90 index cbabb991b..18fcfda09 100644 --- a/physics/GFS_suite_interstitial_4.F90 +++ b/physics/GFS_suite_interstitial_4.F90 @@ -224,7 +224,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) - nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(real(qc_mp(i,k) * rho), real(nwfa(i,k)*rho)) * orho) !> - Convert number concentrations from dry to moist gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) endif @@ -233,7 +233,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) - ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(real(qi_mp(i,k) * rho), real(save_tcp(i,k)) * orho)) !> - Convert number concentrations from dry to moist gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) endif @@ -249,13 +249,13 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr !> - Update cloud water mixing ratio qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) !> - Update cloud water number concentration - gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(real(qc_mp(i,k) * rho), real(nwfa(i,k)*rho)) * orho) endif if (ntinc>0) then !> - Update cloud ice mixing ratio qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) !> - Update cloud ice number concentration - gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(real(qi_mp(i,k) * rho), real(save_tcp(i,k))) * orho) endif enddo enddo @@ -290,4 +290,4 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr end subroutine GFS_suite_interstitial_4_run - end module GFS_suite_interstitial_4 \ No newline at end of file + end module GFS_suite_interstitial_4 diff --git a/physics/calpreciptype.f90 b/physics/calpreciptype.f90 index d3fbb253b..956ed8c55 100644 --- a/physics/calpreciptype.f90 +++ b/physics/calpreciptype.f90 @@ -509,7 +509,14 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) real(kind=kind_phys) rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & rhavg,dtavg,dpk,ptw,pbot ! real(kind=kind_phys) b,qtmp,rate,qc -! real(kind=kind_phys),external :: xmytw (now inside the module) +! + interface + function xmytw(t,td,p) + use machine , only : kind_phys + implicit none + real(kind=kind_phys) t, td, p, xmytw + end function xmytw + end interface ! ! initialize. icefrac = -9999. diff --git a/physics/machine.F b/physics/machine.F index 2ee7fb865..9b09d235c 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -33,7 +33,7 @@ module machine # endif &, kind_rad = 4 & &, kind_phys = 4 ,kind_taum=4 & - &, kind_grid = 4 & + &, kind_grid = 8 &! atmos_cubed_sphere requres kind_grid=8 &, kind_REAL = 4 &! used in cmp_comm &, kind_LOGICAL = 4 & &, kind_INTEGER = 4 ! -,,- diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 6beae0da2..ddbff5725 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -144,11 +144,11 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) real (kind=kind_phys), intent(in) :: grav real (kind=kind_phys), intent(in),dimension(:,:) :: phil,ref3D,tk integer :: i,k,ll,ipt,kpt - real :: dbz1avg,zmidp1,zmidloc,refl,fact - real, dimension(im,levs) :: z - real, dimension(im) :: zintsfc - real, dimension(:), intent(inout) :: refd,refd263k - REAL :: dbz1(2),dbzk,dbzk1 + real(kind_phys) :: dbz1avg,zmidp1,zmidloc,refl,fact + real(kind_phys), dimension(im,levs) :: z + real(kind_phys), dimension(im) :: zintsfc + real(kind_phys), dimension(:), intent(inout) :: refd,refd263k + REAL(kind_phys) :: dbz1(2),dbzk,dbzk1 logical :: counter do i=1,im do k=1,levs @@ -185,7 +185,7 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) dbz1avg=dbz1(2)+(dbz1(2)-dbz1(1))*fact !-- Convert to dBZ (10*logZ) as the last step if (dbz1avg>0.01) then - dbz1avg=10.*alog10(dbz1avg) + dbz1avg=10.*log10(dbz1avg) else dbz1avg=-35. endif @@ -214,7 +214,7 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) dbz1avg=maxval(dbz1) !-- Convert to dBZ (10*logZ) as the last step if (dbz1avg>0.01) then - dbz1avg=10.*alog10(dbz1avg) + dbz1avg=10.*log10(dbz1avg) else dbz1avg=-35. endif diff --git a/physics/mersenne_twister.f b/physics/mersenne_twister.f index 8cc6bd5e5..58bf43487 100644 --- a/physics/mersenne_twister.f +++ b/physics/mersenne_twister.f @@ -160,6 +160,7 @@ ! !$$$ module mersenne_twister + use machine, only: kind_dbl_prec private ! Public declarations public random_stat @@ -188,7 +189,7 @@ module mersenne_twister integer:: mti=n+1 integer:: mt(0:n-1) integer:: iset - real:: gset + real(kind_dbl_prec):: gset end type ! Saved data type(random_stat),save:: sstat @@ -300,8 +301,8 @@ subroutine random_setseed_t(inseed,stat) !> This function generates random numbers in functional mode. function random_number_f() result(harvest) implicit none - real:: harvest - real h(1) + real(kind_dbl_prec):: harvest + real(kind_dbl_prec) :: h(1) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_number_t(h,sstat) harvest=h(1) @@ -310,7 +311,7 @@ function random_number_f() result(harvest) !> This subroutine generates random numbers in interactive mode. subroutine random_number_i(harvest,inseed) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) integer,intent(in):: inseed type(random_stat) stat call random_setseed_t(inseed,stat) @@ -320,7 +321,7 @@ subroutine random_number_i(harvest,inseed) !> This subroutine generates random numbers in saved mode; overloads Fortran 90 standard. subroutine random_number_s(harvest) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_number_t(harvest,sstat) end subroutine @@ -328,7 +329,7 @@ subroutine random_number_s(harvest) !> This subroutine generates random numbers in thread-safe mode. subroutine random_number_t(harvest,stat) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) type(random_stat),intent(inout):: stat integer j,kk,y integer tshftu,tshfts,tshftt,tshftl @@ -359,9 +360,12 @@ subroutine random_number_t(harvest,stat) y=ieor(y,iand(tshftt(y),tmaskc)) y=ieor(y,tshftl(y)) if(y.lt.0) then - harvest(j)=(real(y)+2.0**32)/(2.0**32-1.0) + harvest(j)=(real(y,kind=kind_dbl_prec)+ & + & 2.0_kind_dbl_prec**32)/ & + & (2.0_kind_dbl_prec**32-1.0_kind_dbl_prec) else - harvest(j)=real(y)/(2.0**32-1.0) + harvest(j)=real(y)/(2.0_kind_dbl_prec**32- & + & 1.0_kind_dbl_prec) endif stat%mti=stat%mti+1 enddo @@ -370,8 +374,8 @@ subroutine random_number_t(harvest,stat) !> This subrouitne generates Gaussian random numbers in functional mode. function random_gauss_f() result(harvest) implicit none - real:: harvest - real h(1) + real(kind_dbl_prec):: harvest + real(kind_dbl_prec) :: h(1) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_gauss_t(h,sstat) harvest=h(1) @@ -380,7 +384,7 @@ function random_gauss_f() result(harvest) !> This subrouitne generates Gaussian random numbers in interactive mode. subroutine random_gauss_i(harvest,inseed) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) integer,intent(in):: inseed type(random_stat) stat call random_setseed_t(inseed,stat) @@ -390,7 +394,7 @@ subroutine random_gauss_i(harvest,inseed) !> This subroutine generates Gaussian random numbers in saved mode. subroutine random_gauss_s(harvest) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) call random_gauss_t(harvest,sstat) end subroutine @@ -398,10 +402,10 @@ subroutine random_gauss_s(harvest) !> This subroutine generates Gaussian random numbers in thread-safe mode. subroutine random_gauss_t(harvest,stat) implicit none - real,intent(out):: harvest(:) + real(kind_dbl_prec),intent(out):: harvest(:) type(random_stat),intent(inout):: stat integer mx,my,mz,j - real r2(2),r,g1,g2 + real(kind_dbl_prec) :: r2(2),r,g1,g2 mz=size(harvest) if(mz.le.0) return mx=0 @@ -436,14 +440,14 @@ subroutine random_gauss_t(harvest,stat) contains !> This subroutine contains numerical Recipes algorithm to generate Gaussian random numbers. subroutine rgauss(r1,r2,r,g1,g2) - real,intent(in):: r1,r2 - real,intent(out):: r,g1,g2 - real v1,v2,fac - v1=2.*r1-1. - v2=2.*r2-1. + real(kind_dbl_prec),intent(in):: r1,r2 + real(kind_dbl_prec),intent(out):: r,g1,g2 + real(kind_dbl_prec) :: v1,v2,fac + v1=2._kind_dbl_prec*r1-1._kind_dbl_prec + v2=2._kind_dbl_prec*r2-1._kind_dbl_prec r=v1**2+v2**2 if(r.lt.1.) then - fac=sqrt(-2.*log(r)/r) + fac=sqrt(-2._kind_dbl_prec*log(r)/r) g1=v1*fac g2=v2*fac endif @@ -489,7 +493,7 @@ subroutine random_index_t(imax,iharvest,stat) type(random_stat),intent(inout):: stat integer,parameter:: mh=n integer i1,i2,mz - real h(mh) + real(kind_dbl_prec) :: h(mh) mz=size(iharvest) do i1=1,mz,mh i2=min((i1-1)+mh,mz) diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index 5f227750a..bc874ace6 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -2804,8 +2804,8 @@ SUBROUTINE znot_m_v6(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02,& & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& & p10 = -8.396975715683501e+00, & diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 1c899e4bd..61b92990b 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -681,7 +681,7 @@ subroutine noahmp_sflx (parameters, & logical :: dveg_active !< flag to run dynamic vegetation logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) - real :: canhs ! canopy heat storage change w/m2 + real (kind=kind_phys) :: canhs ! canopy heat storage change w/m2 ! maximum lai/sai used for some parameterizations based on plant growthi @@ -4494,7 +4494,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0_kind_phys,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index b39610bc8..a27d0f287 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -7603,10 +7603,11 @@ END SUBROUTINE SOILIN !>\ingroup lsm_ruc_group !> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). - REAL FUNCTION RSLF(P,T) + FUNCTION RSLF(P,T) IMPLICIT NONE - REAL, INTENT(IN):: P, T + REAL(kind_phys), INTENT(IN):: P, T + REAL(kind_phys) :: RSLF REAL:: ESL,X REAL, PARAMETER:: C0= .611583699E03 REAL, PARAMETER:: C1= .444606896E02 diff --git a/physics/module_soil_pre.F90 b/physics/module_soil_pre.F90 index 8eb5a5775..149f87a1c 100644 --- a/physics/module_soil_pre.F90 +++ b/physics/module_soil_pre.F90 @@ -5,6 +5,8 @@ module module_soil_pre !tgs Initialize RUC LSM levels, soil temp/moisture + use machine, only: kind_phys + implicit none private @@ -26,8 +28,8 @@ SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_levels ) INTEGER, INTENT(IN) :: num_soil_levels - REAL, DIMENSION(1:num_soil_levels), INTENT(OUT) :: zs, dzs - REAL, DIMENSION(1:num_soil_levels) :: zs2 + REAL(kind_phys), DIMENSION(1:num_soil_levels), INTENT(OUT) :: zs, dzs + REAL(kind_phys), DIMENSION(1:num_soil_levels) :: zs2 INTEGER :: l @@ -90,21 +92,21 @@ SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , & INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input - REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input - REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + REAL(kind_phys) , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL(kind_phys) , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk - REAL , DIMENSION(num_soil_layers) :: zs , dzs + REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + REAL(kind_phys) , DIMENSION(num_soil_layers) :: zs , dzs - REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois + REAL(kind_phys) , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois - REAL , ALLOCATABLE , DIMENSION(:) :: zhave + REAL(kind_phys) , ALLOCATABLE , DIMENSION(:) :: zhave logical :: debug_print = .false. INTEGER :: i , j , l , lout , lin , lwant , lhave, k - REAL :: temp + REAL(kind_phys) :: temp ! Allocate the soil layer array used for interpolating. diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index 157da8e09..d6f1d7259 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -371,7 +371,7 @@ subroutine gas_init & endif do k = 1, LOZ - pkstr(k) = fpkapx(pstr(k)*100.0) + pkstr(k) = fpkapx(pstr(k)*100.0_kind_phys) enddo endif ! end if_ioznflg_block diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index df1a368c5..9286c45cb 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_lw type = scheme - dependencies = mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f + dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f ######################################################################## [ccpp-arg-table] diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index ae2fa7ad5..5d7d62dcc 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -2040,7 +2040,7 @@ subroutine mcica_subcol & real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & & fac_lcf(nlay), & & cdfun2(nlay,ngptsw) - real (kind=kind_dbl_prec) :: rand2d(nlay*ngptsw), rand1d(ngptsw) + real (kind=kind_dbl_prec) :: rand2d(nlay*ngptsw), rand1d(ngptsw) ! must be default real kind to match mersenne twister code type (random_stat) :: stat ! for thread safe random generator diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index 70bc136f3..506e2edf0 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw type = scheme - dependencies = mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f + dependencies = machine.F,mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f ######################################################################## [ccpp-arg-table] From e7c42c7d57740d6f8c3852ce3d9dfbab720e6c86 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 5 May 2022 00:43:21 +0000 Subject: [PATCH 4/5] Move some code to modules --- physics/GFS_MP_generic_post.F90 | 2 +- physics/calpreciptype.f90 | 10 +++------- physics/cires_orowam2017.f | 3 +++ physics/cires_ugwp.F90 | 5 +++++ physics/cires_ugwp_triggers.F90 | 3 +++ physics/cires_ugwpv1_oro.F90 | 2 +- physics/cires_ugwpv1_sporo.F90 | 4 +++- physics/hedmf.f | 3 ++- physics/lsm_noah.f | 1 + physics/mfpbl.f | 4 +++- physics/mfpblt.f | 4 +++- physics/mfpbltq.f | 4 +++- physics/mfscu.f | 4 +++- physics/mfscuq.f | 4 +++- physics/module_bl_mynn.F90 | 3 +++ physics/moninshoc.f | 3 +++ physics/satmedmfvdif.F | 4 ++++ physics/satmedmfvdifq.F | 4 +++- physics/sflx.f | 12 +++++++++++- physics/tridi.f | 4 +++- physics/ugwp_driver_v0.F | 5 ++++- physics/unified_ugwp.F90 | 3 ++- 22 files changed, 70 insertions(+), 21 deletions(-) diff --git a/physics/GFS_MP_generic_post.F90 b/physics/GFS_MP_generic_post.F90 index a7be0ab4c..97deec10f 100644 --- a/physics/GFS_MP_generic_post.F90 +++ b/physics/GFS_MP_generic_post.F90 @@ -30,7 +30,7 @@ subroutine GFS_MP_generic_post_run( index_of_process_dfi_radar, ix_dfi_radar, dfi_radar_tten, radar_tten_limits, fhour, errmsg, errflg) ! use machine, only: kind_phys - + use calpreciptype_mod, only: calpreciptype implicit none integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar diff --git a/physics/calpreciptype.f90 b/physics/calpreciptype.f90 index 956ed8c55..54e8fa2b9 100644 --- a/physics/calpreciptype.f90 +++ b/physics/calpreciptype.f90 @@ -1,6 +1,8 @@ !>\file calpreciptype.f90 !! This file contains the subroutines that calculates dominant precipitation type. +module calpreciptype_mod +contains !>\ingroup gfs_calpreciptype !! Foure algorithms are called to calculate dominant precipitation type, and the !!tallies are sumed in calwxt_dominant(). @@ -510,13 +512,6 @@ subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) rhavg,dtavg,dpk,ptw,pbot ! real(kind=kind_phys) b,qtmp,rate,qc ! - interface - function xmytw(t,td,p) - use machine , only : kind_phys - implicit none - real(kind=kind_phys) t, td, p, xmytw - end function xmytw - end interface ! ! initialize. icefrac = -9999. @@ -1391,3 +1386,4 @@ subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & return end !! @} +end module calpreciptype_mod diff --git a/physics/cires_orowam2017.f b/physics/cires_orowam2017.f index c20f98f42..ae5f355d3 100644 --- a/physics/cires_orowam2017.f +++ b/physics/cires_orowam2017.f @@ -1,3 +1,5 @@ + module cires_orowam2017 + contains subroutine oro_wam_2017(im, levs,npt,ipt, kref,kdt,me,master, & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & del, sigma, hprime, gamma, theta, @@ -384,3 +386,4 @@ subroutine ugwpv0_tofd1d(levs, sigflt, elvmax, zsurf, enddo ! end subroutine ugwpv0_tofd1d + end module cires_orowam2017 diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index c4f0a255d..2d8eafc19 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -16,9 +16,14 @@ module cires_ugwp use machine, only: kind_phys use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize + use ugwp_driver_v0 use gwdps, only: gwdps_run + use cires_ugwp_triggers + + use ugwp_driver_v0 + implicit none private diff --git a/physics/cires_ugwp_triggers.F90 b/physics/cires_ugwp_triggers.F90 index 4a8b97590..82f762c56 100644 --- a/physics/cires_ugwp_triggers.F90 +++ b/physics/cires_ugwp_triggers.F90 @@ -1,3 +1,5 @@ + module cires_ugwp_triggers + contains ! subroutine slat_geos5_tamp_v0(im, tau_amp, xlatdeg, tau_gw) !================= @@ -97,3 +99,4 @@ subroutine init_nazdir_v0(naz, xaz, yaz) yaz(4) =-1.0 !S endif end subroutine init_nazdir_v0 + end module cires_ugwp_triggers diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index 247112bf1..66d0e472c 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -1,5 +1,5 @@ module cires_ugwpv1_oro - + use cires_ugwpv1_sporo contains subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & diff --git a/physics/cires_ugwpv1_sporo.F90 b/physics/cires_ugwpv1_sporo.F90 index c840b49d8..fbd3eaa0b 100644 --- a/physics/cires_ugwpv1_sporo.F90 +++ b/physics/cires_ugwpv1_sporo.F90 @@ -1,4 +1,5 @@ - + module cires_ugwpv1_sporo + contains subroutine oro_spectral_solver(im, levs,npt,ipt, kref,kdt,me,master, & dtp,dxres, taub, u1, v1, t1, xn, yn, bn2, rho, prsi, prsL, & del, sigma, hprime, gamma, theta, & @@ -349,3 +350,4 @@ subroutine oro_meanflow(nz, nzi, u1, v1, t1, pint, pmid, & end subroutine oro_meanflow + end module cires_ugwpv1_sporo diff --git a/physics/hedmf.f b/physics/hedmf.f index 83d0fe1b0..604483e53 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -5,7 +5,8 @@ !> This module contains the CCPP-compliant hybrid eddy-diffusivity mass-flux !! scheme. module hedmf - + use tridi_mod + use mfpbl_mod contains !> \section arg_table_hedmf_init Argument Table diff --git a/physics/lsm_noah.f b/physics/lsm_noah.f index d519dcda5..7a8e17bf8 100644 --- a/physics/lsm_noah.f +++ b/physics/lsm_noah.f @@ -7,6 +7,7 @@ module lsm_noah use machine, only: kind_phys use set_soilveg_mod, only: set_soilveg use namelist_soilveg + use sflx implicit none diff --git a/physics/mfpbl.f b/physics/mfpbl.f index 2df84945b..dac548711 100644 --- a/physics/mfpbl.f +++ b/physics/mfpbl.f @@ -1,6 +1,7 @@ !> \file mfpbl.f !! This file contains the subroutine that calculates the updraft properties and mass flux for use in the Hybrid EDMF PBL scheme. - + module mfpbl_mod + contains !> \ingroup HEDMF !! \brief This subroutine is used for calculating the mass flux and updraft properties. !! @@ -396,3 +397,4 @@ subroutine mfpbl(im,ix,km,ntrac,delt,cnvflg, & return end !> @} + end module mfpbl_mod diff --git a/physics/mfpblt.f b/physics/mfpblt.f index bd0baf558..67e554b92 100644 --- a/physics/mfpblt.f +++ b/physics/mfpblt.f @@ -2,7 +2,8 @@ !! This file contains the subroutine that calculates mass flux and !! updraft parcel properties for thermals driven by surface heating !! for use in the TKE-EDMF PBL scheme. - + module mfpblt_mod + contains !>\ingroup satmedmf !! This subroutine computes mass flux and updraft parcel properties for !! thermals driven by surface heating. @@ -452,3 +453,4 @@ subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, & return end !> @} + end module mfpblt_mod diff --git a/physics/mfpbltq.f b/physics/mfpbltq.f index c4333290b..4555af268 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -2,7 +2,8 @@ !! This file contains the subroutine that calculates mass flux and !! updraft parcel properties for thermals driven by surface heating !! for use in the TKE-EDMF PBL scheme (updated version). - + module mfpbltq_mod + contains !>\ingroup satmedmfvdifq !! This subroutine computes mass flux and updraft parcel properties for !! thermals driven by surface heating. @@ -477,3 +478,4 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, return end !> @} + end module mfpbltq_mod diff --git a/physics/mfscu.f b/physics/mfscu.f index 9128c7c10..e0c184139 100644 --- a/physics/mfscu.f +++ b/physics/mfscu.f @@ -1,7 +1,8 @@ !>\file mfscu.f !! This file contains the mass flux and downdraft parcel preperties !! parameterization for stratocumulus-top-driven turbulence. - + module mfscu_mod + contains !>\ingroup satmedmf !! This subroutine computes mass flux and downdraft parcel properties !! for stratocumulus-top-driven turbulence. @@ -554,3 +555,4 @@ subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, & return end !> @} + end module mfscu_mod diff --git a/physics/mfscuq.f b/physics/mfscuq.f index 3c54b0bda..ca4819956 100644 --- a/physics/mfscuq.f +++ b/physics/mfscuq.f @@ -1,7 +1,8 @@ !>\file mfscuq.f !! This file contains the mass flux and downdraft parcel preperties !! parameterization for stratocumulus-top-driven turbulence (updated version). - + module mfscuq_mod + contains !>\ingroup satmedmfvdifq !! This subroutine computes mass flux and downdraft parcel properties !! for stratocumulus-top-driven turbulence. @@ -557,3 +558,4 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, return end !> @} + end module mfscuq_mod diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 7b98b1c93..334d1db4c 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1384,8 +1384,11 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos lb1 = min(dlu,dld) !minimum !JOE-fight floating point errors +#ifdef SINGLE_PREC + !JM: keep up the fight, JOE dlu=MAX(0.1,MIN(dlu,1000.)) dld=MAX(0.1,MIN(dld,1000.)) +#endif lb2 = sqrt(dlu*dld) !average - biased towards smallest !lb2 = 0.5*(dlu+dld) !average diff --git a/physics/moninshoc.f b/physics/moninshoc.f index 4e9e60b46..ee4715e81 100644 --- a/physics/moninshoc.f +++ b/physics/moninshoc.f @@ -4,6 +4,9 @@ !> This module contains the CCPP-compliant SHOC scheme. module moninshoc + use mfpbl_mod + use tridi_mod + contains subroutine moninshoc_init (do_shoc, errmsg, errflg) diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index feb4ef870..f791a2de4 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -5,6 +5,10 @@ module satmedmfvdif + use tridi_mod + use mfscu_mod + use mfpblt_mod + contains !> \section arg_table_satmedmfvdif_init Argument Table diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index eb2b7ad1c..9c5ad4029 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -4,7 +4,9 @@ !! eddy-diffusion mass-flux (TKE-EDMF) parameterization (by Jongil Han). module satmedmfvdifq - + use mfpbltq_mod + use tridi_mod + use mfscuq_mod contains !> \defgroup satmedmfvdifq GFS Scale-aware TKE-based Moist Eddy-Diffusivity Mass-flux (TKE-EDMF, updated version) Scheme Module diff --git a/physics/sflx.f b/physics/sflx.f index 61fe015cc..026e2b854 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -1,6 +1,7 @@ !>\file sflx.f !! This file is the entity of GFS Noah LSM Model(Version 2.7). - + module sflx + contains !>\ingroup Noah_LSM !!\brief This is the entity of GFS Noah LSM model of physics subroutines. !! It is a soil/veg/snowpack land-surface model to update soil moisture, soil @@ -906,7 +907,15 @@ subroutine gfssflx &! --- input eta = etp endif +#ifdef SINGLE_PREC + IF (ETP == 0.0) THEN + BETA = 0.0 + ELSE + BETA = ETA/ETP + ENDIF +#else beta = eta / etp +#endif !> - Convert the sign of soil heat flux so that: !! - ssoil>0: warm the surface (night time) @@ -5801,3 +5810,4 @@ end subroutine wdfcnd end subroutine gfssflx !! @} !----------------------------------- + end module sflx diff --git a/physics/tridi.f b/physics/tridi.f index 0103b388f..13202512f 100644 --- a/physics/tridi.f +++ b/physics/tridi.f @@ -1,6 +1,7 @@ !>\file tridi.f !! These subroutines are originally internal subroutines in moninedmf.f - + module tridi_mod + contains !>\ingroup HEDMF !!\brief Routine to solve the tridiagonal system to calculate !!temperature and moisture at \f$ t + \Delta t \f$; part of two-part @@ -220,3 +221,4 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) return end subroutine tridit !> @} + end module tridi_mod diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index 844acf722..cd19f5f71 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -1,5 +1,7 @@ !>\file ugwp_driver_v0.F - + module ugwp_driver_v0 + use cires_orowam2017 + contains ! !===================================================================== ! @@ -1485,3 +1487,4 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, end subroutine fv3_ugwp_solv2_v0 + end module ugwp_driver_v0 diff --git a/physics/unified_ugwp.F90 b/physics/unified_ugwp.F90 index 9e93bd5fc..0b45d680d 100644 --- a/physics/unified_ugwp.F90 +++ b/physics/unified_ugwp.F90 @@ -37,7 +37,8 @@ module unified_ugwp ! use cires_ugwp_module, only: knob_ugwp_version, cires_ugwp_mod_init, cires_ugwp_mod_finalize use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use gwdps, only: gwdps_run - + use cires_ugwp_triggers + use ugwp_driver_v0 use drag_suite, only: drag_suite_run implicit none From 63020ec6a737511a46102865458b9843e340a404 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Thu, 5 May 2022 22:46:10 +0000 Subject: [PATCH 5/5] Switch to another version of the code that works with 64 bit --- physics/GFS_rrtmgp_cloud_overlap.F90 | 4 ++-- physics/GFS_suite_interstitial_4.F90 | 10 +++++----- physics/cires_ugwp.F90 | 4 ---- physics/cires_ugwpv1_oro.F90 | 2 +- physics/hedmf.f | 2 ++ physics/maximum_hourly_diagnostics.F90 | 14 +++++++------- physics/module_bl_mynn.F90 | 23 ++++++++++++++++++----- physics/module_sf_mynn.F90 | 4 ++-- physics/module_sf_noahmplsm.f90 | 4 ++-- physics/module_sf_ruclsm.F90 | 5 ++--- physics/module_soil_pre.F90 | 24 +++++++++++------------- physics/radiation_gases.f | 2 +- physics/satmedmfvdif.F | 2 -- physics/surface_perturbation.F90 | 2 +- 14 files changed, 54 insertions(+), 48 deletions(-) diff --git a/physics/GFS_rrtmgp_cloud_overlap.F90 b/physics/GFS_rrtmgp_cloud_overlap.F90 index c1a6c4763..13794641b 100644 --- a/physics/GFS_rrtmgp_cloud_overlap.F90 +++ b/physics/GFS_rrtmgp_cloud_overlap.F90 @@ -99,7 +99,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! Cloud overlap parameter ! if (iovr == iovr_dcorr .or. iovr == iovr_exp .or. iovr == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001_kind_phys, de_lgth, cld_frac, cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr, iovr_exprand, deltaZc*0.001, de_lgth, cld_frac, cloud_overlap_param) else de_lgth(:) = 0. cloud_overlap_param(:,:) = 0. @@ -110,7 +110,7 @@ subroutine GFS_rrtmgp_cloud_overlap_run(nCol, nLev, yearlen, doSWrad, doLWrad, ! if (imfdeepcnv == imfdeepcnv_samf .or. imfdeepcnv == imfdeepcnv_gf) then if (iovr_convcld == iovr_dcorr .or. iovr_convcld == iovr_exp .or. iovr_convcld == iovr_exprand) then - call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001_kind_phys, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) + call get_alpha_exper(nCol, nLev, iovr_convcld, iovr_exprand, deltaZc*0.001, de_lgth, cld_cnv_frac, cnv_cloud_overlap_param) else de_lgth(:) = 0. cnv_cloud_overlap_param(:,:) = 0. diff --git a/physics/GFS_suite_interstitial_4.F90 b/physics/GFS_suite_interstitial_4.F90 index 18fcfda09..cbabb991b 100644 --- a/physics/GFS_suite_interstitial_4.F90 +++ b/physics/GFS_suite_interstitial_4.F90 @@ -224,7 +224,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) - nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(real(qc_mp(i,k) * rho), real(nwfa(i,k)*rho)) * orho) + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) !> - Convert number concentrations from dry to moist gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) endif @@ -233,7 +233,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) - ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(real(qi_mp(i,k) * rho), real(save_tcp(i,k)) * orho)) + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) !> - Convert number concentrations from dry to moist gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) endif @@ -249,13 +249,13 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr !> - Update cloud water mixing ratio qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) !> - Update cloud water number concentration - gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(real(qc_mp(i,k) * rho), real(nwfa(i,k)*rho)) * orho) + gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) endif if (ntinc>0) then !> - Update cloud ice mixing ratio qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) !> - Update cloud ice number concentration - gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(real(qi_mp(i,k) * rho), real(save_tcp(i,k))) * orho) + gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) endif enddo enddo @@ -290,4 +290,4 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr end subroutine GFS_suite_interstitial_4_run - end module GFS_suite_interstitial_4 + end module GFS_suite_interstitial_4 \ No newline at end of file diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index 2d8eafc19..f2d6b3e3c 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -17,13 +17,9 @@ module cires_ugwp use cires_ugwpv0_module, only: knob_ugwp_version, cires_ugwpv0_mod_init, cires_ugwpv0_mod_finalize use ugwp_driver_v0 - use gwdps, only: gwdps_run - use cires_ugwp_triggers - use ugwp_driver_v0 - implicit none private diff --git a/physics/cires_ugwpv1_oro.F90 b/physics/cires_ugwpv1_oro.F90 index 66d0e472c..959bbd6c5 100644 --- a/physics/cires_ugwpv1_oro.F90 +++ b/physics/cires_ugwpv1_oro.F90 @@ -1,5 +1,5 @@ module cires_ugwpv1_oro - use cires_ugwpv1_sporo + use cires_ugwpv1_sporo contains subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & diff --git a/physics/hedmf.f b/physics/hedmf.f index 604483e53..a1d8df9c3 100644 --- a/physics/hedmf.f +++ b/physics/hedmf.f @@ -5,8 +5,10 @@ !> This module contains the CCPP-compliant hybrid eddy-diffusivity mass-flux !! scheme. module hedmf + use tridi_mod use mfpbl_mod + contains !> \section arg_table_hedmf_init Argument Table diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index ddbff5725..6beae0da2 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -144,11 +144,11 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) real (kind=kind_phys), intent(in) :: grav real (kind=kind_phys), intent(in),dimension(:,:) :: phil,ref3D,tk integer :: i,k,ll,ipt,kpt - real(kind_phys) :: dbz1avg,zmidp1,zmidloc,refl,fact - real(kind_phys), dimension(im,levs) :: z - real(kind_phys), dimension(im) :: zintsfc - real(kind_phys), dimension(:), intent(inout) :: refd,refd263k - REAL(kind_phys) :: dbz1(2),dbzk,dbzk1 + real :: dbz1avg,zmidp1,zmidloc,refl,fact + real, dimension(im,levs) :: z + real, dimension(im) :: zintsfc + real, dimension(:), intent(inout) :: refd,refd263k + REAL :: dbz1(2),dbzk,dbzk1 logical :: counter do i=1,im do k=1,levs @@ -185,7 +185,7 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) dbz1avg=dbz1(2)+(dbz1(2)-dbz1(1))*fact !-- Convert to dBZ (10*logZ) as the last step if (dbz1avg>0.01) then - dbz1avg=10.*log10(dbz1avg) + dbz1avg=10.*alog10(dbz1avg) else dbz1avg=-35. endif @@ -214,7 +214,7 @@ subroutine max_fields(phil,ref3D,grav,im,levs,refd,tk,refd263k) dbz1avg=maxval(dbz1) !-- Convert to dBZ (10*logZ) as the last step if (dbz1avg>0.01) then - dbz1avg=10.*log10(dbz1avg) + dbz1avg=10.*alog10(dbz1avg) else dbz1avg=-35. endif diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 334d1db4c..f16ca722a 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1384,11 +1384,9 @@ SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos lb1 = min(dlu,dld) !minimum !JOE-fight floating point errors -#ifdef SINGLE_PREC !JM: keep up the fight, JOE dlu=MAX(0.1,MIN(dlu,1000.)) dld=MAX(0.1,MIN(dld,1000.)) -#endif lb2 = sqrt(dlu*dld) !average - biased towards smallest !lb2 = 0.5*(dlu+dld) !average @@ -1542,11 +1540,9 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos lb1(iz) = min(dlu(iz),dld(iz)) !minimum !JOE-fight floating point errors -#ifdef SINGLE_PREC !JM: keep up the fight, JOE dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) -#endif lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average @@ -2955,8 +2951,12 @@ SUBROUTINE mym_condensation (kts,kte, & zagl = zagl + dz(k) !CLOUD WATER AND ICE - IF (q1k < 0.) THEN !unstaurated + IF (q1k < 0.) THEN !unsaturated +#ifdef SINGLE_PREC ql_water = sgm(k)*EXP(1.2*q1k-1.) +#else + ql_water = sgm(k)*EXP(1.2*q1k-1) +#endif ql_ice = sgm(k)*EXP(1.2*q1k-1.) !Reduce ice mixing ratios in the upper troposphere ! low_weight = MIN(MAX(p(k)-40000.0, 0.0),40000.0)/40000.0 @@ -7608,15 +7608,28 @@ FUNCTION qsat_blend(t, P, waterice) IF ((t .GE. 273.16) .OR. (wrt .EQ. 'w')) THEN ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) +#ifdef SINGLE_PREC qsat_blend = 0.622*ESL/max((P-ESL),1.0E-7_kind_phys) +#else + qsat_blend = 0.622*ESL/(P-ESL) +#endif ELSE IF (t .LE. 253.) THEN ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) +#ifdef SINGLE_PREC qsat_blend = 0.622*ESI/max((P-ESI),1.0E-7_kind_phys) +#else + qsat_blend = 0.622*ESI/(P-ESI) +#endif ELSE ESL = J0+XC*(J1+XC*(J2+XC*(J3+XC*(J4+XC*(J5+XC*(J6+XC*(J7+XC*J8))))))) ESI = K0+XC*(K1+XC*(K2+XC*(K3+XC*(K4+XC*(K5+XC*(K6+XC*(K7+XC*K8))))))) +#ifdef SINGLE_PREC RSLF = 0.622*ESL/max((P-ESL),1.0E-7_kind_phys) RSIF = 0.622*ESI/max((P-ESI),1.0E-7_kind_phys) +#else + RSLF = 0.622*ESL/(P-ESL) + RSIF = 0.622*ESI/(P-ESI) +#endif chi = (273.16-t)/20.16 qsat_blend = (1.-chi)*RSLF + chi*RSIF END IF diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 index e14c23882..22b142c33 100644 --- a/physics/module_sf_mynn.F90 +++ b/physics/module_sf_mynn.F90 @@ -2804,8 +2804,8 @@ SUBROUTINE znot_m_v6(uref, znotm) ! znotm(meter): areodynamical roughness scale over water ! - REAL, INTENT(IN) :: uref - REAL, INTENT(OUT):: znotm + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znotm real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02,& & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00,& & p10 = -8.396975715683501e+00, & diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 61b92990b..1c899e4bd 100644 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -681,7 +681,7 @@ subroutine noahmp_sflx (parameters, & logical :: dveg_active !< flag to run dynamic vegetation logical :: crop_active !< flag to run crop model ! add canopy heat storage (C.He added based on GY Niu's communication) - real (kind=kind_phys) :: canhs ! canopy heat storage change w/m2 + real :: canhs ! canopy heat storage change w/m2 ! maximum lai/sai used for some parameterizations based on plant growthi @@ -4494,7 +4494,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & if(opt_sfc == 3) then call sfcdif3(parameters,iloc ,jloc ,iter ,sfctmp ,qair ,ur , & !in zlvl ,tgb ,thsfc_loc,prslkix,prsik1x ,prslk1x ,z0m , & !in - zpd ,snowh,shdfac ,garea1 ,.false. ,0.0_kind_phys,ivgtyp , & !in + zpd ,snowh,shdfac ,garea1 ,.false. ,0.0,ivgtyp , & !in ustarx ,fm ,fh ,fm2 ,fh2 , & !inout z0h ,fv ,csigmaf0,cm ,ch ) !out diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index a27d0f287..b39610bc8 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -7603,11 +7603,10 @@ END SUBROUTINE SOILIN !>\ingroup lsm_ruc_group !> This function calculates the liquid saturation vapor mixing ratio as !! a function of temperature and pressure (from Thompson scheme). - FUNCTION RSLF(P,T) + REAL FUNCTION RSLF(P,T) IMPLICIT NONE - REAL(kind_phys), INTENT(IN):: P, T - REAL(kind_phys) :: RSLF + REAL, INTENT(IN):: P, T REAL:: ESL,X REAL, PARAMETER:: C0= .611583699E03 REAL, PARAMETER:: C1= .444606896E02 diff --git a/physics/module_soil_pre.F90 b/physics/module_soil_pre.F90 index 149f87a1c..8eb5a5775 100644 --- a/physics/module_soil_pre.F90 +++ b/physics/module_soil_pre.F90 @@ -5,8 +5,6 @@ module module_soil_pre !tgs Initialize RUC LSM levels, soil temp/moisture - use machine, only: kind_phys - implicit none private @@ -28,8 +26,8 @@ SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_levels ) INTEGER, INTENT(IN) :: num_soil_levels - REAL(kind_phys), DIMENSION(1:num_soil_levels), INTENT(OUT) :: zs, dzs - REAL(kind_phys), DIMENSION(1:num_soil_levels) :: zs2 + REAL, DIMENSION(1:num_soil_levels), INTENT(OUT) :: zs, dzs + REAL, DIMENSION(1:num_soil_levels) :: zs2 INTEGER :: l @@ -92,21 +90,21 @@ SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , & INTEGER , DIMENSION(1:num_st_levels_input) , INTENT(INOUT) :: st_levels_input INTEGER , DIMENSION(1:num_sm_levels_input) , INTENT(INOUT) :: sm_levels_input - REAL(kind_phys) , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input - REAL(kind_phys) , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input - REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst + REAL , DIMENSION(ims:ime,1:num_st_levels_alloc,jms:jme) , INTENT(INOUT) :: st_input + REAL , DIMENSION(ims:ime,1:num_sm_levels_alloc,jms:jme) , INTENT(INOUT) :: sm_input + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: landmask , sst - REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn - REAL(kind_phys) , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk - REAL(kind_phys) , DIMENSION(num_soil_layers) :: zs , dzs + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk + REAL , DIMENSION(num_soil_layers) :: zs , dzs - REAL(kind_phys) , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois + REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois - REAL(kind_phys) , ALLOCATABLE , DIMENSION(:) :: zhave + REAL , ALLOCATABLE , DIMENSION(:) :: zhave logical :: debug_print = .false. INTEGER :: i , j , l , lout , lin , lwant , lhave, k - REAL(kind_phys) :: temp + REAL :: temp ! Allocate the soil layer array used for interpolating. diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f index d6f1d7259..157da8e09 100644 --- a/physics/radiation_gases.f +++ b/physics/radiation_gases.f @@ -371,7 +371,7 @@ subroutine gas_init & endif do k = 1, LOZ - pkstr(k) = fpkapx(pstr(k)*100.0_kind_phys) + pkstr(k) = fpkapx(pstr(k)*100.0) enddo endif ! end if_ioznflg_block diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index f791a2de4..c7fe1d5c0 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -4,11 +4,9 @@ !! eddy-diffusion mass-flux (TKE-EDMF) parameterization (by Jongil Han). module satmedmfvdif - use tridi_mod use mfscu_mod use mfpblt_mod - contains !> \section arg_table_satmedmfvdif_init Argument Table diff --git a/physics/surface_perturbation.F90 b/physics/surface_perturbation.F90 index 7ddbe5279..e0429a5fc 100644 --- a/physics/surface_perturbation.F90 +++ b/physics/surface_perturbation.F90 @@ -48,7 +48,7 @@ subroutine cdfnor(z,cdfz) cdfz = 0.5 else x = 0.5*z*z - call cdfgam(x,0.5_kind_phys,del,iflag, cdfx) + call cdfgam(x,0.5,del,iflag, cdfx) if (iflag.ne.0) return if (z.gt.0.0) then cdfz = 0.5+0.5*cdfx