From 99ac1a07c34926adf6e5ac03d59138e7a073a6fe Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 4 Mar 2020 00:48:54 +0000 Subject: [PATCH 01/30] updating cycle to distingush lakes from ocean --- physics/gcycle.F90 | 8 + physics/sfcsub.F | 947 ++++++++++++++++++++++++--------------------- 2 files changed, 518 insertions(+), 437 deletions(-) diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index bb1730fc2..b6c085a29 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -62,6 +62,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 @@ -151,6 +153,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) @@ -185,6 +192,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/physics/sfcsub.F b/physics/sfcsub.F index 6296e7856..c0bb760f1 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -69,14 +69,18 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, 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 + 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, & @@ -87,7 +91,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & snolmx,snolmn,snoomx,snoomn,snosmx, & & snosmn,snoimx,snoimn,snojmx,snojmn, & & zorlmx,zorlmn,zoromx,zoromn,zorsmx, & - & zorsmn,zorimx,zorimn,zorjmx, zorjmn, & + & zorsmn,zorimx,zorimn,zorjmx,zorjmn, & & plrlmx,plrlmn,plromx,plromn,plrsmx, & & plrsmn,plrimx,plrimn,plrjmx,plrjmn, & & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, & @@ -284,8 +288,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, @@ -447,34 +452,34 @@ 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 & + 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) & + 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) & + 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) ! @@ -482,13 +487,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! 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) & + 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) @@ -572,8 +577,8 @@ 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 + real :: tem ! ! debug only ! @@ -794,7 +799,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. @@ -811,15 +816,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 @@ -838,175 +843,175 @@ 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) + 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 ---------------------------------------------------------------------- ! !> - 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 @@ -1114,32 +1119,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 @@ -1153,6 +1161,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! set ocean/land/sea-ice mask ! call setlsi(slmask,aisclm,len,aicice,sliclm) + ! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' ! *,sliclm(iprnt),' slmask=',slmask(iprnt) ! @@ -1170,7 +1179,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! quality control of snow depth (note that snow should be corrected first ! because it influences tsf ! - kqcm=1 + kqcm = 1 call qcmxmn('snow ',snoclm,sliclm,snoclm,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, & snojmx,snojmn,snosmx,snosmn,epssno, @@ -1194,7 +1203,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, @@ -1246,7 +1255,7 @@ 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 + if(lsoil > 2) then call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, @@ -1256,7 +1265,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & 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, @@ -1268,7 +1277,7 @@ 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 + if(lsoil > 2) then call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, @@ -1295,10 +1304,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, @@ -1321,7 +1330,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 *,' ' @@ -1371,7 +1380,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,*) '==============' @@ -1395,9 +1404,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! reverse scaling to match with grib analysis input ! - zsca=0.01 + zsca = 0.01 call scale(zoranl,len, zsca) - zsca=100. + zsca = 100. call scale(albanl,len,zsca) call scale(albanl(1,2),len,zsca) call scale(albanl(1,3),len,zsca) @@ -1405,12 +1414,12 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call scale(alfanl,len,zsca) call scale(alfanl(1,2),len,zsca) !clu [+4l] reverse scale for vmn, vmx, abs - zsca=100. + zsca = 100. call scale(vmnanl,len,zsca) call scale(vmxanl,len,zsca) call scale(absanl,len,zsca) ! - percrit=critp2 + percrit = critp2 ! ! read analysis fields ! @@ -1438,9 +1447,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! scale zor and alb to match forecast model units ! - zsca=100. + zsca = 100. call scale(zoranl,len, zsca) - zsca=0.01 + zsca = 0.01 call scale(albanl,len,zsca) call scale(albanl(1,2),len,zsca) call scale(albanl(1,3),len,zsca) @@ -1448,7 +1457,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call scale(alfanl,len,zsca) call scale(alfanl(1,2),len,zsca) !clu [+4] scale vmn, vmx, abs from percent to fraction - zsca=0.01 + zsca = 0.01 call scale(vmnanl,len,zsca) call scale(vmxanl,len,zsca) call scale(absanl,len,zsca) @@ -1470,42 +1479,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. @@ -1516,9 +1531,10 @@ 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=' @@ -1551,10 +1567,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 ! @@ -1563,13 +1579,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, @@ -1581,7 +1597,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, @@ -1599,7 +1615,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, @@ -1634,7 +1650,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, @@ -1646,7 +1662,7 @@ 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 + if(lsoil > 2) then call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, @@ -1656,7 +1672,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & 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, @@ -1668,7 +1684,7 @@ 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 + if(lsoil > 2) then call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, @@ -1712,7 +1728,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 *,' ' @@ -1761,20 +1777,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' + 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, @@ -1792,13 +1808,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, @@ -1813,7 +1829,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 @@ -1841,23 +1857,23 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! compute soil moisture liquid-to-total ratio over land ! do j=1, lsoil - do i=1, len - if(smcfcs(i,j) .ne. 0.) then - swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) - else - swratio(i,j) = -999. - endif - enddo + do i=1, len + if(smcfcs(i,j) /= 0.) then + swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) + else + swratio(i,j) = -999. + endif + enddo 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, @@ -1872,7 +1888,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, @@ -1898,10 +1914,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, @@ -1975,7 +1991,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 *,' ' @@ -2042,14 +2058,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 ! @@ -2103,9 +2119,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, @@ -2120,8 +2136,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, @@ -2146,8 +2161,16 @@ 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) + call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2m ',smcanl(1,2),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.gt.2) then + if(lsoil > 2) then call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, @@ -2156,17 +2179,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) - endif - call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2m ',smcanl(1,2),slianl,snoanl,icefl1, - & 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, @@ -2194,10 +2206,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, @@ -2217,7 +2229,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,*) '==============' @@ -2247,7 +2259,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)' @@ -2331,7 +2343,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)' @@ -2424,15 +2436,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 + tem = 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) * tem + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem else tsffcs(i) = tsfanl(i) ! tsffcs(i) = tgice @@ -2442,13 +2460,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 @@ -2457,29 +2482,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 @@ -2490,13 +2515,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. @@ -2504,16 +2529,16 @@ 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) - swdfcs(i) = 10.* snofcs(i) - endif + 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 enddo ! landice mods - impose same minimum snow depth at @@ -2523,7 +2548,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 @@ -4481,43 +4506,43 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) end !>\ingroup mod_sfcsub - 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).ge.crit) then - aisfld(i)=1. + if(aisfld(i) >= crit) 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) 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) 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) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo else @@ -4528,6 +4553,61 @@ subroutine rof01(aisfld,len,op,crit) return end +!>\ingroup mod_sfcsub + 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) >= crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'gt') then + do i=1,len + if(aisfld(i) > crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'le') then + do i=1,len + if(aisfld(i) <= crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'lt') then + do i=1,len + if(aisfld(i) < crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + else + write(6,*) ' illegal operator in rof01. op=',op + call abort + endif +! + return + end !>\ingroup mod_sfcsub subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) ! @@ -5215,7 +5295,7 @@ subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, & ! ! 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 @@ -5315,9 +5395,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 @@ -5342,59 +5421,56 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! 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) @@ -5403,24 +5479,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 @@ -5429,11 +5505,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 @@ -5442,11 +5518,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 @@ -5455,11 +5531,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 @@ -5468,11 +5544,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 @@ -5481,11 +5557,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 @@ -5494,11 +5570,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 @@ -5507,11 +5583,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 @@ -5520,11 +5595,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 @@ -5533,24 +5608,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 @@ -5559,11 +5633,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 @@ -5572,11 +5646,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 @@ -5585,12 +5659,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 @@ -5599,11 +5673,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 @@ -5612,11 +5686,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 @@ -5625,11 +5699,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 @@ -5638,12 +5712,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 @@ -5652,11 +5726,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 @@ -5667,78 +5741,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 From f8eb82ca3da1e4dfd8665064998ff02279107002 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 5 Mar 2020 12:39:17 +0000 Subject: [PATCH 02/30] minot changes in sfcsub --- physics/sfcsub.F | 246 +++++++++++++++++++++++------------------------ 1 file changed, 121 insertions(+), 125 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index c0bb760f1..f9c3af1f7 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -67,7 +67,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & &, vegfcs,vetfcs,sotfcs,alffcs & - &, cvfcs,cvbfcs,cvtfcs,me,nlunit & + &, 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) @@ -152,7 +152,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, sihnew integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, & - & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, & + & 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, & @@ -578,7 +578,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! qced in the forecast program) ! logical :: ldebug, lqcbgs, lprnt - real :: tem ! ! debug only ! @@ -842,7 +841,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! deltf = deltsfc / 24.0 ! - ctsfl=0. !... tsfc over land + ctsfl = 0. !... tsfc over land if (ftsfl >= 99999.) ctsfl = 1. if (ftsfl > 0. .and. ftsfl < 99999) ctsfl = exp(-deltf/ftsfl) ! @@ -1256,16 +1255,16 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcclm(3:4) 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) + 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) == ' ') 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, @@ -1277,15 +1276,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 > 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, @@ -1579,7 +1578,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! quality control of snow and sea-ice ! process snow depth or snow cover ! - if(fnsnoa(1:8) /= ' ') 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 @@ -1627,7 +1626,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, @@ -1662,15 +1661,15 @@ 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 > 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) == ' ') then call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) @@ -1684,15 +1683,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 > 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, @@ -1808,7 +1807,7 @@ 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) /= 0.) then + if (sig1t(1) /= 0.) then call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, & tsfimx) do i=1,len @@ -1867,7 +1866,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & enddo !clu ----------------------------------------------------------------------- ! - if(lqcbgs .and. irtacn == 0) then + if (lqcbgs .and. irtacn == 0) then call qcsli(slianl,slifcs,len,me) call albocn(albfcs,slmask,albomx,len) do i=1,len @@ -1927,15 +1926,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, @@ -1946,15 +1945,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, @@ -2006,7 +2005,7 @@ 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 + 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) @@ -2170,25 +2169,25 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & 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) + 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, @@ -2275,13 +2274,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) @@ -2361,11 +2360,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) @@ -2447,10 +2446,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif if (slifcs(i) >= 2.) then if (sicfcs(i) > crit) then - tem = 1.0 / sicfcs(i) + tem1 = 1.0 / sicfcs(i) tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice) * tem - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem + & + (sicfcs(i)-sicanl(i))*tgice) * tem1 + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 else tsffcs(i) = tsfanl(i) ! tsffcs(i) = tgice @@ -2535,7 +2534,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do i = 1, len if(slifcs(i) == 1.) then if(snofcs(i) /= 0. .and. swdfcs(i) == 0.) then - print *,'dbgx --scale snwdph from sheleg', + print *,'dbgx --scale snwdph from sheleg', & & i, swdfcs(i), snofcs(i) swdfcs(i) = 10.* snofcs(i) endif @@ -2857,8 +2856,7 @@ subroutine fixrdg(lugb,idim,jdim,fngrib, & !>\ingroup mod_sfcsub !! This subroutine get area of the grib record. - 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 @@ -3749,7 +3747,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & & 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, & + & 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 @@ -3840,36 +3838,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 @@ -3877,30 +3875,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 @@ -5395,7 +5393,7 @@ subroutine setlsi(slmask,aisfld,len,aicice,slifld) ! do i=1,len slifld(i) = slmask(i) - if(aisfld(i) == aicice .and. slmask(i) == 0.0) + if(aisfld(i) == aicice .and. slmask(i) == 0.0) & & slifld(i) = 2.0 enddo return @@ -6069,21 +6067,19 @@ subroutine qcsli(slianl,slifcs,len,me) !>\ingroup mod_sfcsub subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, & & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, & - & zoranl,smcanl, & - & smcclm,tsfsmx,albomx,zoromx, me) + & 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 ! @@ -6091,7 +6087,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. From ab6cb5ae9292efe62b1866f62783266d60a11c50 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 10 Mar 2020 19:26:24 +0000 Subject: [PATCH 03/30] correcting errors in ccpp when levr < levs; this fix is essential for Whole Atmosphere Model --- physics/GFS_rrtmg_post.F90 | 12 ++-- physics/GFS_rrtmg_pre.F90 | 138 +++++++++++++++--------------------- physics/GFS_rrtmg_setup.F90 | 4 +- physics/dcyc2.meta | 24 +++---- physics/moninedmf.meta | 12 ++-- physics/rrtmg_lw_post.F90 | 9 ++- physics/rrtmg_lw_pre.F90 | 4 +- physics/rrtmg_sw_post.F90 | 10 +-- physics/rrtmg_sw_pre.F90 | 6 +- physics/satmedmfvdif.meta | 12 ++-- physics/satmedmfvdifq.meta | 12 ++-- physics/ysuvdif.meta | 4 +- 12 files changed, 113 insertions(+), 134 deletions(-) diff --git a/physics/GFS_rrtmg_post.F90 b/physics/GFS_rrtmg_post.F90 index db3de4f44..498138d6c 100644 --- a/physics/GFS_rrtmg_post.F90 +++ b/physics/GFS_rrtmg_post.F90 @@ -44,12 +44,12 @@ subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, & integer, intent(in) :: im, lm, ltp, kt, kb, kd, nday real(kind=kind_phys), intent(in) :: raddt - real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(in) :: aerodp - real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(in) :: cldsa - integer, dimension(size(Grid%xlon,1),3), intent(in) :: mbota, mtopa - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: clouds1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: cldtausw - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: cldtaulw + real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(in) :: aerodp + real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(in) :: cldsa + integer, dimension(size(Grid%xlon,1),3), intent(in) :: mbota, mtopa + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: clouds1 + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: cldtausw + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: cldtaulw character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index aa1ea039e..679c1afa9 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -85,61 +85,40 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input integer, intent(out) :: kd, kt, kb ! F-A mp scheme only - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_ice - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_rain - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_rimef - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: cwm - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: flgmin + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: f_ice, & + f_rain, f_rimef + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: cwm + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: flgmin real(kind=kind_phys), intent(out) :: raddt + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: delp, & + dz, plyr, tlyr, qlyr, olyr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: delp - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: dz - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP), intent(out) :: plvl - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: plyr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP), intent(out) :: tlvl - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: tlyr - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: tsfg - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: tsfa - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: qlyr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: olyr - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_co2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_n2o - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_ch4 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_o2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_co - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_cfc11 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_cfc12 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_cfc22 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_ccl4 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_cfc113 - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW), intent(out) :: faersw1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW), intent(out) :: faersw2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW), intent(out) :: faersw3 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW), intent(out) :: faerlw1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW), intent(out) :: faerlw2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW), intent(out) :: faerlw3 - - real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(out) :: aerodp - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds3 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds4 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds5 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds6 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds7 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds8 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds9 - real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(out) :: cldsa - integer, dimension(size(Grid%xlon,1),3), intent(out) :: mbota - integer, dimension(size(Grid%xlon,1),3), intent(out) :: mtopa - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: de_lgth - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: alb1d + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+1+LTP), intent(out) :: plvl, tlvl + + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: tsfg, tsfa + + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: gasvmr_co2, & + gasvmr_n2o, gasvmr_ch4, gasvmr_o2, gasvmr_co, gasvmr_cfc11, & + gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, gasvmr_cfc113 + + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDSW), intent(out) :: faersw1, & + faersw2, faersw3 + + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDLW), intent(out) :: faerlw1, & + faerlw2, faerlw3 + + real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(out) :: aerodp + + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: clouds1, & + clouds2, clouds3, clouds4, clouds5, clouds6, clouds7, clouds8, clouds9 + + real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(out) :: cldsa + integer, dimension(size(Grid%xlon,1),3), intent(out) :: mbota, mtopa + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: de_lgth, alb1d character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(out) :: errflg ! Local variables integer :: me, nfxr, ntrac, ntcw, ntiw, ncld, ntrw, ntsw, ntgl, ncndl @@ -150,21 +129,21 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: cvt1, cvb1, tem1d, tskn - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: & + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP) :: & htswc, htlwc, gcice, grain, grime, htsw0, htlw0, & rhly, tvly,qstl, vvel, clw, ciw, prslk1, tem2da, & cldcov, deltaq, cnvc, cnvw, & effrl, effri, effrr, effrs - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP+1) :: tem2db -! real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP+1) :: hz + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP+1) :: tem2db +! real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP+1) :: hz - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,min(4,Model%ncnd)) :: ccnd - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,2:Model%ntrac) :: tracer1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_CLDS) :: clouds - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_VGAS) :: gasvmr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW,NF_AESW)::faersw - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW,NF_AELW)::faerlw + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,min(4,Model%ncnd)) :: ccnd + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,2:Model%ntrac) :: tracer1 + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NF_CLDS) :: clouds + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NF_VGAS) :: gasvmr + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDSW,NF_AESW) ::faersw + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDLW,NF_AELW) ::faerlw ! !===> ... begin here ! @@ -175,8 +154,8 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input if (.not. (Model%lsswr .or. Model%lslwr)) return !--- set commonly used integers - me = Model%me - NFXR = Model%nfxr + me = Model%me + NFXR = Model%nfxr NTRAC = Model%ntrac ! tracers in grrad strip off sphum - start tracer1(2:NTRAC) ntcw = Model%ntcw ntiw = Model%ntiw @@ -209,16 +188,16 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input llb = 1 ! local index at toa level lya = 2 ! local index for the 2nd layer from top lyb = 1 ! local index for the top layer - endif ! end if_ivflip_block + endif ! end if_ivflip_block else kd = 0 - if ( ivflip == 1 ) then ! vertical from sfc upward + if ( ivflip == 1 ) then ! vertical from sfc upward kt = 1 ! index diff between lyr and upper bound kb = 0 ! index diff between lyr and lower bound - else ! vertical from toa downward + else ! vertical from toa downward kt = 0 ! index diff between lyr and upper bound kb = 1 ! index diff between lyr and lower bound - endif ! end if_ivflip_block + endif ! end if_ivflip_block endif ! end if_lextop_block raddt = min(Model%fhswr, Model%fhlwr) @@ -247,7 +226,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input lsk = 0 if (ivflip == 0 .and. lm < Model%levs) lsk = Model%levs - lm -! convert pressure unit from pa to mb +! convert pressure unit from pa to mb do k = 1, LM k1 = k + kd k2 = k + lsk @@ -275,38 +254,39 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input enddo ! if (ivflip == 0) then ! input data from toa to sfc - do i = 1, IM - plvl(i,1+kd) = 0.01 * Statein%prsi(i,1) ! pa to mb (hpa) - enddo - if (lsk /= 0) then + if (lsk > 0) then + k1 = 1 + kd + k2 = k1 + kb do i = 1, IM - plvl(i,1+kd) = 0.5 * (plvl(i,2+kd) + plvl(i,1+kd)) + 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 enddo endif else ! input data from sfc to top - do i = 1, IM - plvl(i,LP1+kd) = 0.01 * Statein%prsi(i,LP1+lsk) ! pa to mb (hpa) - enddo - if (lsk /= 0) then + if (Model%levs > lm) then + k1 = lm + kd do i = 1, IM - plvl(i,LM+kd) = 0.5 * (plvl(i,LP1+kd) + plvl(i,LM+kd)) + 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 enddo endif endif - +! 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) tlyr(i,lyb) = tlyr(i,lya) - prslk1(i,lyb) = (plyr(i,lyb)*0.00001) ** rocp ! plyr in Pa + prslk1(i,lyb) = (plyr(i,lyb)*0.001) ** rocp ! plyr in Pa rhly(i,lyb) = rhly(i,lya) qstl(i,lyb) = qstl(i,lya) enddo ! --- note: may need to take care the top layer amount - tracer1(:,lyb,:) = tracer1(:,lya,:) + tracer1(:,lyb,:) = tracer1(:,lya,:) endif diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index b6d86a34e..b3c91cacc 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -400,7 +400,7 @@ subroutine radinit( si, NLAY, imp_physics, me ) ! ! ! attributes: ! ! language: fortran 90 ! -! machine: wcoss ! +! machine: wcoss ! ! ! ! ==================== definition of variables ==================== ! ! ! @@ -683,7 +683,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & ! solcon : sun-earth distance adjusted solar constant (w/m2) ! ! ! ! external module variables: ! -! isolar : solar constant cntrl (in module physparam) ! +! isolar : solar constant cntrl (in module physparam) ! ! = 0: use the old fixed solar constant in "physcon" ! ! =10: use the new fixed solar constant in "physcon" ! ! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index c4a8d9051..552264f52 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -183,37 +183,37 @@ intent = in optional = F [swh] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step - long_name = total sky shortwave heating rate on radiation time step + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep + long_name = total sky sw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in optional = F [swhc] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_assuming_clear_sky_on_radiation_time_step - long_name = clear sky shortwave heating rate on radiation time step + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_assuming_clear_sky_on_radiation_timestep + long_name = clear sky sw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in optional = F [hlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step - long_name = total sky longwave heating rate on radiation time step + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky lw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in optional = F [hlwc] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_time_step - long_name = clear sky longwave heating rate on radiation time step + standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_timestep + long_name = clear sky lw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 47875640f..5d75aea22 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -145,19 +145,19 @@ intent = in optional = F [swh] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step - long_name = total sky shortwave heating rate + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep + long_name = total sky sw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in optional = F [hlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step - long_name = total sky longwave heating rate + standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_on_radiation_timestep + long_name = total sky lw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in diff --git a/physics/rrtmg_lw_post.F90 b/physics/rrtmg_lw_post.F90 index 971b278dd..af83c5cc7 100644 --- a/physics/rrtmg_lw_post.F90 +++ b/physics/rrtmg_lw_post.F90 @@ -30,9 +30,8 @@ subroutine rrtmg_lw_post_run (Model, Grid, Radtend, Coupling, & type(GFS_grid_type), intent(in) :: Grid type(GFS_radtend_type), intent(inout) :: Radtend integer, intent(in) :: im, ltp, LM, kd - real(kind=kind_phys), dimension(size(Grid%xlon,1), Model%levr+LTP), intent(in) :: htlwc - real(kind=kind_phys), dimension(size(Grid%xlon,1), Model%levr+LTP), intent(in) :: htlw0 - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa + real(kind=kind_phys), dimension(size(Grid%xlon,1), lm+LTP), intent(in) :: htlwc, htlw0 + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! local variables @@ -54,7 +53,7 @@ subroutine rrtmg_lw_post_run (Model, Grid, Radtend, Coupling, & enddo ! --- repopulate the points above levr if (lm < Model%levs) then - do k = lm,Model%levs + do k = lm+1,Model%levs Radtend%htrlw (1:im,k) = Radtend%htrlw (1:im,LM) enddo endif @@ -66,7 +65,7 @@ subroutine rrtmg_lw_post_run (Model, Grid, Radtend, Coupling, & enddo ! --- repopulate the points above levr if (lm < Model%levs) then - do k = lm,Model%levs + do k = lm+1,Model%levs Radtend%lwhc(1:im,k) = Radtend%lwhc(1:im,LM) enddo endif diff --git a/physics/rrtmg_lw_pre.F90 b/physics/rrtmg_lw_pre.F90 index 5f128a79a..7de02eed1 100644 --- a/physics/rrtmg_lw_pre.F90 +++ b/physics/rrtmg_lw_pre.F90 @@ -30,7 +30,7 @@ subroutine rrtmg_lw_pre_run (Model, Grid, Sfcprop, Radtend, im, tsfg, tsfa, errm type(GFS_sfcprop_type), intent(in) :: Sfcprop type(GFS_grid_type), intent(in) :: Grid integer, intent(in) :: im - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -44,7 +44,7 @@ subroutine rrtmg_lw_pre_run (Model, Grid, Sfcprop, Radtend, im, tsfg, tsfa, errm call setemis (Grid%xlon, Grid%xlat, Sfcprop%slmsk, & ! --- inputs Sfcprop%snowd, Sfcprop%sncovr, Sfcprop%zorl, & tsfg, tsfa, Sfcprop%hprime(:,1), IM, & - Radtend%semis) ! --- outputs + Radtend%semis) ! --- outputs endif end subroutine rrtmg_lw_pre_run diff --git a/physics/rrtmg_sw_post.F90 b/physics/rrtmg_sw_post.F90 index e11491d48..b0ab31129 100644 --- a/physics/rrtmg_sw_post.F90 +++ b/physics/rrtmg_sw_post.F90 @@ -34,9 +34,9 @@ subroutine rrtmg_sw_post_run (Model, Grid, Diag, Radtend, Coupling, & type(GFS_radtend_type), intent(inout) :: Radtend type(GFS_grid_type), intent(in) :: Grid type(GFS_diag_type), intent(inout) :: Diag - integer, intent(in) :: im, lm, kd, nday, ltp - type(cmpfsw_type), dimension(size(Grid%xlon,1)), intent(inout) :: scmpsw - real(kind=kind_phys), dimension(Size(Grid%xlon,1), Model%levr+LTP), intent(in) :: htswc, htsw0 + integer, intent(in) :: im, lm, kd, nday, ltp + type(cmpfsw_type), dimension(size(Grid%xlon,1)), intent(inout) :: scmpsw + real(kind=kind_phys), dimension(Size(Grid%xlon,1), lm+LTP), intent(in) :: htswc, htsw0 real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: sfcalb1, sfcalb2, sfcalb3, sfcalb4 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -56,7 +56,7 @@ subroutine rrtmg_sw_post_run (Model, Grid, Diag, Radtend, Coupling, & ! We are assuming that radiative tendencies are from bottom to top ! --- repopulate the points above levr i.e. LM if (lm < Model%levs) then - do k = lm,Model%levs + do k = lm+1,Model%levs Radtend%htrsw (1:im,k) = Radtend%htrsw (1:im,LM) enddo endif @@ -68,7 +68,7 @@ subroutine rrtmg_sw_post_run (Model, Grid, Diag, Radtend, Coupling, & enddo ! --- repopulate the points above levr i.e. LM if (lm < Model%levs) then - do k = lm,Model%levs + do k = lm+1,Model%levs Radtend%swhc(1:im,k) = Radtend%swhc(1:im,LM) enddo endif diff --git a/physics/rrtmg_sw_pre.F90 b/physics/rrtmg_sw_pre.F90 index 8eeb16430..05e8d4c7b 100644 --- a/physics/rrtmg_sw_pre.F90 +++ b/physics/rrtmg_sw_pre.F90 @@ -35,7 +35,7 @@ subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & integer, intent(in) :: im integer, intent(out) :: nday integer, dimension(size(Grid%xlon,1)), intent(out) :: idxday - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: sfcalb1, sfcalb2, sfcalb3, sfcalb4 real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: alb1d character(len=*), intent(out) :: errmsg @@ -73,12 +73,12 @@ subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, & Sfcprop%tisfc, IM, & alb1d, Model%pertalb, & ! mg, sfc-perts - sfcalb) ! --- outputs + sfcalb) ! --- outputs !> -# Approximate mean surface albedo from vis- and nir- diffuse values. Radtend%sfalb(:) = max(0.01, 0.5 * (sfcalb(:,2) + sfcalb(:,4))) else - nday = 0 + nday = 0 idxday = 0 sfcalb = 0.0 endif diff --git a/physics/satmedmfvdif.meta b/physics/satmedmfvdif.meta index 63480e01b..50668d204 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/satmedmfvdif.meta @@ -249,19 +249,19 @@ intent = in optional = F [swh] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step - long_name = total sky shortwave heating rate + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep + long_name = total sky sw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in optional = F [hlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step - long_name = total sky longwave heating rate + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky lw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index ec679faec..6fa8b143b 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -249,19 +249,19 @@ intent = in optional = F [swh] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step - long_name = total sky shortwave heating rate + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep + long_name = total sky sw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in optional = F [hlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step - long_name = total sky longwave heating rate + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep + long_name = total sky lw heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in diff --git a/physics/ysuvdif.meta b/physics/ysuvdif.meta index 458ff75ae..12819dee5 100644 --- a/physics/ysuvdif.meta +++ b/physics/ysuvdif.meta @@ -128,7 +128,7 @@ standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step long_name = total sky shortwave heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in @@ -137,7 +137,7 @@ standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step long_name = total sky longwave heating rate units = K s-1 - dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys intent = in From 3ba810b49098baa82e30e4e157b31f584022c79e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 30 Mar 2020 15:42:39 -0400 Subject: [PATCH 04/30] a bug fix --- physics/GFS_rrtmg_pre.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 679c1afa9..71f89f305 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -262,6 +262,11 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input plyr(i,k1) = 0.5 * (plvl(i,k2+1) + plvl(i,k2)) prslk1(i,k1) = (plyr(i,k1)*0.001) ** rocp enddo + else + k1 = 1 + kd + do i = 1, IM + plvl(i,k1) = Statein%prsi(i,1) * 0.01 ! pa to mb (hpa) + enddo endif else ! input data from sfc to top if (Model%levs > lm) then @@ -271,6 +276,11 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input plyr(i,k1) = 0.5 * (plvl(i,k1+1) + plvl(i,k1)) prslk1(i,k1) = (plyr(i,k1)*0.001) ** rocp enddo + else + k1 = lp1 + kd + do i = 1, IM + plvl(i,k1) = Statein%prsi(i,lp1) * 0.01 ! pa to mb (hpa) + enddo endif endif ! From f1c24fbd54d66fa78bb776d3770cd97b5dd2ba89 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 20 Apr 2020 23:34:01 +0000 Subject: [PATCH 05/30] after merging with NCAR/ccpp-physics/master and some bug fixes in some physics routines --- physics/GFS_MP_generic.F90 | 121 ++++--- physics/GFS_PBL_generic.F90 | 9 +- physics/GFS_suite_interstitial.F90 | 6 +- physics/GFS_surface_composites.F90 | 81 ++--- physics/GFS_surface_composites.meta | 9 + physics/GFS_surface_generic.F90 | 14 +- physics/GFS_surface_loop_control.F90 | 4 +- physics/gcm_shoc.F90 | 64 ++-- physics/m_micro.F90 | 518 +++++++++++++-------------- physics/micro_mg_utils.F90 | 60 ++-- physics/moninshoc.f | 104 +++--- physics/rascnv.F90 | 392 ++++++++++---------- physics/sfc_cice.f | 8 +- physics/sfc_diff.f | 188 +++++----- physics/sfc_drv.f | 86 ++--- physics/sfc_ocean.F | 42 +-- physics/sfc_ocean.meta | 18 - physics/sfc_sice.f | 23 +- 18 files changed, 874 insertions(+), 873 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index ab68e206a..bcf11db66 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -97,8 +97,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt logical, intent(in) :: cal_pre, lssav, ldiag3d, cplflx, cplchm real(kind=kind_phys), intent(in) :: dtf, frain, con_g - real(kind=kind_phys), dimension(im), intent(in) :: rainc, rain1, xlat, xlon, tsfc - real(kind=kind_phys), dimension(im), intent(inout) :: ice, snow, graupel + real(kind=kind_phys), dimension(im), intent(in) :: rain1, xlat, xlon, tsfc + real(kind=kind_phys), dimension(im), intent(inout) :: ice, snow, graupel, rainc real(kind=kind_phys), dimension(im), intent(in) :: rain0, ice0, snow0, graupel0 real(kind=kind_phys), dimension(ix,nrcm), intent(in) :: rann real(kind=kind_phys), dimension(im,levs), intent(in) :: gt0, prsl, save_t, save_qv, del @@ -149,7 +149,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt integer :: i, k, ic real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 - real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip + real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2 real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 ! Initialize CCPP error handling variables @@ -157,7 +157,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt errflg = 0 onebg = one/con_g - + do i = 1, im rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit enddo @@ -171,7 +171,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt ! physics timestep, while Diag%{rain,rainc} and all totprecip etc ! are on the dynamics timestep. Confusing, but works if frain=1. *DH if (imp_physics == imp_physics_gfdl) then - tprcp = max(0., rain) ! clu: rain -> tprcp + tprcp = max(zero, rain) ! clu: rain -> tprcp !graupel = frain*graupel0 !ice = frain*ice0 !snow = frain*snow0 @@ -180,13 +180,13 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt snow = snow0 ! Do it right from the beginning for Thompson else if (imp_physics == imp_physics_thompson) then - tprcp = max (0.,rainc + frain * rain1) ! time-step convective and explicit precip + tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip graupel = frain*graupel0 ! time-step graupel ice = frain*ice0 ! time-step ice snow = frain*snow0 ! time-step snow else if (imp_physics == imp_physics_fer_hires) then - tprcp = max (0.,rain) ! time-step convective and explicit precip + tprcp = max (zero, rain) ! time-step convective and explicit precip ice = frain*rain1*sr ! time-step ice end if @@ -200,7 +200,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt !Note (GJF): Precipitation LWE thicknesses are multiplied by the frain factor, and are thus on the dynamics time step, but the conversion as written ! (with dtp in the denominator) assumes the rate is calculated on the physics time step. This only works as expected when dtf=dtp (i.e. when frain=1). if (lsm == lsm_noahmp) then - tem = 1.0 / (dtp*con_p001) !GJF: This conversion was taken from GFS_physics_driver.F90, but should denominator also have the frain factor? + tem = one / (dtp*con_p001) !GJF: This conversion was taken from GFS_physics_driver.F90, but should denominator also have the frain factor? draincprv(:) = tem * raincprv(:) drainncprv(:) = tem * rainncprv(:) dsnowprv(:) = tem * snowprv(:) @@ -221,11 +221,11 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson) then do i=1,im - tprcp(i) = max(0.0, rain(i) ) - if(doms(i) > 0.0 .or. domip(i) > 0.0) then - srflag(i) = 1. + tprcp(i) = max(zero, rain(i) ) + if(doms(i) > zero .or. domip(i) > zero) then + srflag(i) = one else - srflag(i) = 0. + srflag(i) = zero end if enddo endif @@ -240,34 +240,6 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt endif - if (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 - cnvprcp (i) = cnvprcp (i) + rainc(i) - totprcp (i) = totprcp (i) + rain(i) - totice (i) = totice (i) + ice(i) - totsnw (i) = totsnw (i) + snow(i) - totgrp (i) = totgrp (i) + graupel(i) - - cnvprcpb(i) = cnvprcpb(i) + rainc(i) - totprcpb(i) = totprcpb(i) + rain(i) - toticeb (i) = toticeb (i) + ice(i) - totsnwb (i) = totsnwb (i) + snow(i) - totgrpb (i) = totgrpb (i) + graupel(i) - enddo - - if (ldiag3d) then - do k=1,levs - do i=1,im - dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain -! dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain - enddo - enddo - endif - endif - t850(1:im) = gt0(1:im,1) do k = 1, levs-1 @@ -294,12 +266,12 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt if (lsm /= lsm_ruc) then do i = 1, im !tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp ! DH now lines 245-250 - srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) - if (tsfc(i) >= 273.15) then + srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) + if (tsfc(i) >= 273.15d0) then crain = rainc(i) - csnow = 0.0 + csnow = zero else - crain = 0.0 + crain = zero csnow = rainc(i) endif ! if (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow > rain0(i,1)+crain) then @@ -319,30 +291,65 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt endif ! lsm==lsm_ruc elseif( .not. cal_pre) then if (imp_physics == imp_physics_mg) then ! MG microphysics - tem = con_day / (dtp * con_p001) ! mm / day do i=1,im - tprcp(i) = max(0.0, rain(i) ) ! clu: rain -> tprcp - if (rain(i)*tem > rainmin) then - srflag(i) = max(zero, min(one, (rain(i)-rainc(i))*sr(i)/rain(i))) + if (rain(i) > rainmin) then + tem1 = max(zero, (rain(i)-rainc(i))) * sr(i) + tem2 = one / rain(i) + if (t850(i) > 273.16d0) then + srflag(i) = max(zero, min(one, tem1*tem2)) + else + srflag(i) = max(zero, min(one, (tem1+rainc(i))*tem2)) + endif else - srflag(i) = 0.0 + srflag(i) = zero + rain(i) = zero + rainc(i) = zero endif + tprcp(i) = max(zero, rain(i) ) ! clu: rain -> tprcp enddo else do i = 1, im - tprcp(i) = max(0.0, rain(i) ) ! clu: rain -> tprcp - srflag(i) = 0.0 ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16) then - srflag(i) = 1.0 ! clu: set srflag to 'snow' (i.e. 1) + tprcp(i) = max(zero, rain(i) ) ! clu: rain -> tprcp + srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) + if (t850(i) <= 273.16d0) then + srflag(i) = one ! clu: set srflag to 'snow' (i.e. 1) endif enddo endif endif + if (lssav) then +! if (Model%me == 0) print *,'in phys drive, kdt=',kdt, & +! 'totprcpb=', totprcpb(1),'totprcp=',totprcp(1), & +! 'rain=',rain(1) + do i=1,im + cnvprcp (i) = cnvprcp (i) + rainc(i) + totprcp (i) = totprcp (i) + rain(i) + totice (i) = totice (i) + ice(i) + totsnw (i) = totsnw (i) + snow(i) + totgrp (i) = totgrp (i) + graupel(i) + + cnvprcpb(i) = cnvprcpb(i) + rainc(i) + totprcpb(i) = totprcpb(i) + rain(i) + toticeb (i) = toticeb (i) + ice(i) + totsnwb (i) = totsnwb (i) + snow(i) + totgrpb (i) = totgrpb (i) + graupel(i) + enddo + + if (ldiag3d) then + do k=1,levs + do i=1,im + dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain +! dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain + enddo + enddo + endif + endif + if (cplflx .or. cplchm) then do i = 1, im - drain_cpl(i) = rain(i) * (one-srflag(i)) - dsnow_cpl(i) = rain(i) * srflag(i) + dsnow_cpl(i)= max(zero, rain(i) * srflag(i)) + drain_cpl(i)= max(zero, rain(i) - dsnow_cpl(i)) rain_cpl(i) = rain_cpl(i) + drain_cpl(i) snow_cpl(i) = snow_cpl(i) + dsnow_cpl(i) enddo @@ -354,10 +361,10 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt enddo endif - pwat(:) = 0.0 + pwat(:) = zero do k = 1, levs do i=1, im - work1(i) = 0.0 + work1(i) = zero enddo if (ncld > 0) then do ic = ntcw, ntcw+nncl-1 diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index ff59aa465..e8fed5ed8 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -335,8 +335,9 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, real(kind=kind_phys), parameter :: one = 1.0d0 real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue, same as in GFS_typedefs.F90 real(kind=kind_phys), parameter :: epsln = 1.0d-10 ! same as in GFS_physics_driver.F90 + real(kind=kind_phys), parameter :: qmin = 1.0d-8 integer :: i, k, kk, k1, n - real(kind=kind_phys) :: tem, tem1, rho + real(kind=kind_phys) :: tem, rho ! Initialize CCPP error handling variables errmsg = '' @@ -488,8 +489,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, if (cplchm) then do i = 1, im - tem1 = max(q1(i), 1.e-8) - tem = prsl(i,1) / (rd*t1(i)*(one+fvirt*tem1)) + tem = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) ushfsfci(i) = -cp * tem * hflx(i) ! upward sensible heat flux enddo ! dkt_cpl has dimensions (1:im,1:levs), but dkt has (1:im,1:levs-1) @@ -508,8 +508,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dtsfci_cpl(i) = dtsfc_cice(i) dqsfci_cpl(i) = dqsfc_cice(i) elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point - tem1 = max(q1(i), 1.e-8) - rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*tem1)) + rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) if (wind(i) > zero) then tem = - rho * stress_ocn(i) / wind(i) dusfci_cpl(i) = tem * ugrs1(i) ! U-momentum flux diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 935dd9430..a8d5f5b8b 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -201,7 +201,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl logical, dimension(im) :: invrsn real(kind=kind_phys), dimension(im) :: tx1, tx2 - real(kind=kind_phys), parameter :: qmin = 1.0d-10 + real(kind=kind_phys), parameter :: qmin = 1.0d-10, epsln=1.0d-10 ! Initialize CCPP error handling variables errmsg = '' @@ -246,13 +246,13 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl elseif (icy(i)) then ! ice (and water) tem = one - cice(i) if (flag_cice(i)) then - if (wet(i) .and. adjsfculw_ocn(i) /= huge) then + if (wet(i) .and. abs(adjsfculw_ocn(i)-huge) > epsln) then adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_ocn(i)*tem else adjsfculw(i) = ulwsfc_cice(i) endif else - if (wet(i) .and. adjsfculw_ocn(i) /= huge) then + if (wet(i) .and. abs(adjsfculw_ocn(i)-huge) > epsln) then adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_ocn(i)*tem else adjsfculw(i) = adjsfculw_ice(i) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 7cd552e69..c98650b99 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -39,7 +39,7 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl ! Interface variables integer, intent(in ) :: im logical, intent(in ) :: frac_grid, cplflx, cplwav2atm - logical, dimension(im), intent(in ) :: flag_cice + logical, dimension(im), intent(inout) :: flag_cice logical, dimension(im), intent(inout) :: dry, icy, lake, ocean, wet real(kind=kind_phys), intent(in ) :: cimin real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, oceanfrac @@ -53,7 +53,7 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl tsurf_lnd, tsurf_ice, uustar_lnd, uustar_ice, weasd_ocn, weasd_lnd, weasd_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(im), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice - integer, dimension(im), intent(in ) :: islmsk + integer, dimension(im), intent(inout) :: islmsk real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad real(kind=kind_phys), dimension(im), intent(inout) :: semis_ocn, semis_lnd, semis_ice real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice @@ -78,13 +78,16 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl if (cice(i) >= min_seaice) then icy(i) = .true. else - cice(i) = zero + cice(i) = zero + flag_cice(i) = .false. + islmsk = 0 endif else if (cice(i) >= min_lakeice) then icy(i) = .true. else cice(i) = zero + islmsk = 0 endif endif if (cice(i) < one ) then @@ -99,29 +102,35 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl else do i = 1, IM - frland(i) = zero - if (islmsk(i) == 0) then - ! tsfco(i) = Sfcprop%tsfc(i) - wet(i) = .true. - cice(i) = zero - elseif (islmsk(i) == 1) then - ! Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) + if (islmsk(i) == 1) then +! tsfcl(i) = tsfc(i) dry(i) = .true. frland(i) = one cice(i) = zero - else - icy(i) = .true. + else + frland(i) = zero + if (flag_cice(i)) then + if (cice(i) > min_seaice) then + icy(i) = .true. + else + cice(i) = zero + flag_cice(i) = .false. + islmsk(i) = 0 + endif + else + if (cice(i) > min_lakeice) then + icy(i) = .true. + else + cice(i) = zero + islmsk(i) = 0 + endif + endif if (cice(i) < one) then - wet(i) = .true. - ! tsfco(i) = tgice - if (.not. cplflx) tsfco(i) = max(tisfc(i), tgice) - ! if (.not. cplflx .or. lakefrac(i) > zero) tsfco(i) = max(tsfco(i), tisfc(i), tgice) - ! tsfco(i) = max((tsfc(i) - cice(i)*tisfc(i)) & - ! / (one - cice(i)), tgice) + wet(i)=.true. ! some open ocean/lake water exists + if (.not. cplflx) tsfco(i) = max(tsfco(i), tisfc(i), tgice) endif endif enddo - endif if (.not. cplflx .or. .not. frac_grid) then @@ -293,7 +302,7 @@ subroutine GFS_surface_composites_post_run ( cmm, cmm_ocn, cmm_lnd, cmm_ice, chh, chh_ocn, chh_lnd, chh_ice, gflx, gflx_ocn, gflx_lnd, gflx_ice, ep1d, ep1d_ocn, & ep1d_lnd, ep1d_ice, weasd, weasd_ocn, weasd_lnd, weasd_ice, snowd, snowd_ocn, snowd_lnd, snowd_ice, tprcp, tprcp_ocn, & tprcp_lnd, tprcp_ice, evap, evap_ocn, evap_lnd, evap_ice, hflx, hflx_ocn, hflx_lnd, hflx_ice, qss, qss_ocn, qss_lnd, & - qss_ice, tsfc, tsfco, tsfcl, tsfc_ocn, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, errmsg, errflg) + qss_ice, tsfc, tsfco, tsfcl, tsfc_ocn, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, errmsg, errflg) implicit none @@ -314,6 +323,7 @@ subroutine GFS_surface_composites_post_run ( real(kind=kind_phys), dimension(im), intent(in ) :: tice ! interstitial sea ice temperature real(kind=kind_phys), dimension(im), intent(inout) :: hice, cice + real(kind=kind_phys), intent(in ) :: min_seaice character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -452,23 +462,30 @@ subroutine GFS_surface_composites_post_run ( hflx(i) = hflx_ocn(i) qss(i) = qss_ocn(i) tsfc(i) = tsfc_ocn(i) - !hice(i) = zero - !cice(i) = zero - !tisfc(i) = tsfc(i) + hice(i) = zero + cice(i) = zero + tisfc(i) = tsfc(i) else ! islmsk(i) == 2 zorl(i) = zorl_ice(i) cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) rb(i) = rb_ice(i) - stress(i) = cice(i)*stress_ice(i) + (one-cice(i))*stress_ocn(i) ffmm(i) = ffmm_ice(i) ffhh(i) = ffhh_ice(i) uustar(i) = uustar_ice(i) fm10(i) = fm10_ice(i) fh2(i) = fh2_ice(i) + stress(i) = stress_ice(i) !tsurf(i) = tsurf_ice(i) if (.not. flag_cice(i)) then tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + elseif (wet(i) .and. cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_ocn(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_ocn(i) + tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_ocn(i) + stress(i) = txi * stress_ice(i) + txo * stress_ocn(i) endif cmm(i) = cmm_ice(i) chh(i) = chh_ice(i) @@ -487,22 +504,6 @@ subroutine GFS_surface_composites_post_run ( zorll(i) = zorl_lnd(i) zorlo(i) = zorl_ocn(i) - if (flag_cice(i) .and. wet(i)) then ! this was already done for lake ice in sfc_sice - txi = cice(i) - txo = one - txi - evap(i) = txi * evap_ice(i) + txo * evap_ocn(i) - hflx(i) = txi * hflx_ice(i) + txo * hflx_ocn(i) - tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_ocn(i) - else - if (islmsk(i) == 2) then - tisfc(i) = tice(i) - else ! over open ocean or land (no ice fraction) - hice(i) = zero - cice(i) = zero - tisfc(i) = tsfc(i) - endif - endif - enddo endif ! if (frac_grid) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 832d9227e..82e5a4289 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -1650,6 +1650,15 @@ kind = kind_phys intent = inout optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = ??? + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index ac366ae54..9cdf14d85 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -246,7 +246,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - real(kind=kind_phys), parameter :: albdf = 0.06d0 + real(kind=kind_phys), parameter :: albdf = 0.06d0 integer :: i real(kind=kind_phys) :: xcosz_loc, ocalnirdf_cpl, ocalnirbm_cpl, ocalvisdf_cpl, ocalvisbm_cpl @@ -304,12 +304,12 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt ! if (Sfcprop%landfrac(i) < one) then ! Not 100% land if (wet(i)) then ! some open water ! --- compute open water albedo - xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) - ocalnirdf_cpl = 0.06 - ocalnirbm_cpl = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & - & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & - & * (xcosz_loc-1.0)) - ocalvisdf_cpl = 0.06 + xcosz_loc = max( zero, min( one, xcosz(i) )) + ocalnirdf_cpl = 0.06d0 + ocalnirbm_cpl = 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 = 0.06d0 ocalvisbm_cpl = ocalnirbm_cpl nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) diff --git a/physics/GFS_surface_loop_control.F90 b/physics/GFS_surface_loop_control.F90 index c701c523e..c7f727d27 100644 --- a/physics/GFS_surface_loop_control.F90 +++ b/physics/GFS_surface_loop_control.F90 @@ -47,7 +47,7 @@ subroutine GFS_surface_loop_control_part1_run (im, iter, wind, flag_guess, errms errflg = 0 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 @@ -110,7 +110,7 @@ subroutine GFS_surface_loop_control_part2_run (im, iter, wind, & 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) .and. nstf_name1 > 0)) then if (dry(i) .or. (wet(i) .and. nstf_name1 > 0)) then flag_iter(i) = .true. diff --git a/physics/gcm_shoc.F90 b/physics/gcm_shoc.F90 index b32843bc1..9baa61516 100644 --- a/physics/gcm_shoc.F90 +++ b/physics/gcm_shoc.F90 @@ -46,7 +46,7 @@ subroutine shoc_run (ix, nx, nzm, tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - real(kind=kind_phys), parameter :: epsq = 1.d-20 + real(kind=kind_phys), parameter :: epsq = 1.0d-20, zero=0.0d0, one=1.0d0 integer :: i, k @@ -69,15 +69,15 @@ subroutine shoc_run (ix, nx, nzm, tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, do i=1,nx qc(i,k) = gq0(i,k,ntcw) if (abs(qc(i,k)) < epsq) then - qc(i,k) = 0.0 + qc(i,k) = zero endif - tem = qc(i,k) * max(0.0, MIN(1.0, (tcr-gt0(i,k))*tcrf)) + tem = qc(i,k) * max(zero, MIN(one, (tcr-gt0(i,k))*tcrf)) qi(i,k) = tem ! ice qc(i,k) = qc(i,k) - tem ! water - qrn(i,k) = 0.0 - qsnw(i,k) = 0.0 - ncpl(i,k) = 0 - ncpi(i,k) = 0 + qrn(i,k) = zero + qsnw(i,k) = zero + ncpl(i,k) = zero + ncpi(i,k) = zero enddo enddo else @@ -617,7 +617,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 @@ -661,7 +661,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) @@ -849,7 +849,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 @@ -993,7 +993,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) @@ -1053,7 +1053,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 @@ -1084,7 +1084,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))) @@ -1092,7 +1092,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 @@ -1211,7 +1211,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) @@ -1234,7 +1234,7 @@ subroutine canuto() !aab ! Implemetation of the C01 approach in this subroutine is nearly complete @@ -1362,21 +1362,21 @@ subroutine assumed_pdf() ELSE !aab 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) @@ -1450,12 +1450,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 @@ -1489,7 +1489,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) & @@ -1648,8 +1648,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 om1 = max(zero, min(one, (tabs(i,k)-tbgmin)*a_bg)) @@ -1658,16 +1657,9 @@ subroutine assumed_pdf() + fac_sub *(diag_qi+qpi(i,k)) & + tkesbdiss(i,k) * (dtn/cp) ! tke dissipative heating -! 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) - 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 (ntlnc > 0) then ! liquid and ice number concentrations predicted if (ncpl(i,k) > nmin) then @@ -1682,6 +1674,12 @@ 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) + cld_sgs(i,k) = diag_frac + ! 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) diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 83ff8d554..521070af7 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -19,12 +19,12 @@ module m_micro !> \section arg_table_m_micro_init Argument Table !! \htmlinclude m_micro_init.html !! -subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, cpair, & +subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, cpair,& eps, tmelt, latvap, latice, mg_dcs, mg_qcvar, mg_ts_auto_ice, & - mg_rhmini, microp_uniform, do_cldice, hetfrz_classnuc, & - mg_precip_frac_method, mg_berg_eff_factor, sed_supersat, & - do_sb_physics, mg_do_hail, mg_do_graupel, mg_nccons, & - mg_nicons, mg_ngcons, mg_ncnst, mg_ninst, mg_ngnst, & + mg_rhmini, microp_uniform, do_cldice, hetfrz_classnuc, & + mg_precip_frac_method, mg_berg_eff_factor, sed_supersat, & + do_sb_physics, mg_do_hail, mg_do_graupel, mg_nccons, & + mg_nicons, mg_ngcons, mg_ncnst, mg_ninst, mg_ngnst, & mg_do_ice_gmao, mg_do_liq_liu, errmsg, errflg) use machine, only: kind_phys @@ -175,16 +175,16 @@ subroutine m_micro_run( 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, & - & 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 + 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.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, kdt, fprcp, pdfflag + integer,intent(in) :: im, ix,lm, kdt, fprcp, pdfflag, iccn logical,intent(in) :: flipv, skip_macro - integer,intent(in) :: iccn real (kind=kind_phys), intent(in):: dt_i, alf_fac, qc_min(2) real (kind=kind_phys), dimension(ix,lm),intent(in) :: & @@ -353,27 +353,28 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & sflx, gflx ! 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 & +! &, dcrit=20.0d-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 + 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.1 type (AerProps), dimension (IM,LM) :: AeroProps @@ -438,9 +439,9 @@ subroutine m_micro_run( 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) @@ -454,8 +455,8 @@ subroutine m_micro_run( 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 @@ -483,7 +484,6 @@ subroutine m_micro_run( 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) @@ -499,9 +499,9 @@ subroutine m_micro_run( 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) @@ -514,8 +514,8 @@ subroutine m_micro_run( 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 @@ -551,19 +551,19 @@ subroutine m_micro_run( 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 @@ -577,8 +577,8 @@ subroutine m_micro_run( 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 @@ -657,8 +657,8 @@ subroutine m_micro_run( 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 @@ -667,38 +667,38 @@ subroutine m_micro_run( 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) ) - - 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)) - if (iccn .ne. 1) then - CDNC_NUC(i,l) = 0.0 - INC_NUC(i,l) = 0.0 + blk_l(i,l) = one / ( one/max(0.15d0*ZPBL(i),0.4d0*zlo(i,lm-1))& + & + one/(zlo(i,l)*0.4d0) ) + + SC_ICE(i,l) = one + 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 (iccn /= 1) then + 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 @@ -730,18 +730,18 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! allocate(AERMASSMIX(IM,LM,15)) - if (iccn == 2) then + if ( iccn == 2) 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() 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 @@ -752,58 +752,58 @@ subroutine m_micro_run( 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.0d0*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 @@ -816,37 +816,37 @@ subroutine m_micro_run( 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 preparation) 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 @@ -856,8 +856,8 @@ subroutine m_micro_run( 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 @@ -866,25 +866,25 @@ subroutine m_micro_run( 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) & + 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) @@ -902,11 +902,11 @@ subroutine m_micro_run( 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 @@ -921,8 +921,8 @@ subroutine m_micro_run( 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 & @@ -943,7 +943,7 @@ subroutine m_micro_run( 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) @@ -952,63 +952,63 @@ subroutine m_micro_run( 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 -! 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 + ccn_diag(:) = zero + smaxliq(K) = zero + swparc(K) = zero + smaxicer8(K) = zero + nheticer8(K) = zero + sc_icer8(K) = 2.0d0 +! sc_icer8(K) = 1.0d0 + 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) ! if(temp(i,k) > T_ICE_ALL) SC_ICE(i,k) = 1.0 ! if(temp(i,k) > TICE) SC_ICE(i,k) = rhc(i,k) ! - if(iccn == 0) then + if (iccn == 0) then 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 + * t_ice_denom endif endif - if (iccn .ne. 1) then + if (iccn /= 1) then 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) @@ -1121,24 +1121,24 @@ subroutine m_micro_run( 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 (iccn .ne. 1) then - if (PFRZ(i,k) > 0.0) then + if (iccn /= 1) 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 @@ -1195,21 +1195,21 @@ subroutine m_micro_run( 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 @@ -1222,35 +1222,35 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & !! Gettelman (2008) microphysics \cite Morrison_2008 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) @@ -1264,23 +1264,23 @@ subroutine m_micro_run( 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 @@ -1296,7 +1296,7 @@ subroutine m_micro_run( 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 @@ -1305,11 +1305,11 @@ subroutine m_micro_run( 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 @@ -1317,12 +1317,12 @@ subroutine m_micro_run( 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 @@ -1402,8 +1402,8 @@ subroutine m_micro_run( 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 @@ -1414,17 +1414,17 @@ subroutine m_micro_run( 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.5d0*1.0d6, 150.0d0) + CLDREFFS(I,k) = max(0.192d0*dsoutr8(k)*0.5d0*1.0d6, 250.0d0) enddo ! K loop @@ -1506,8 +1506,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, & & 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.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 @@ -1516,15 +1516,15 @@ subroutine m_micro_run( 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),150.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,:) @@ -1532,13 +1532,13 @@ subroutine m_micro_run( 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 ! @@ -1643,8 +1643,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, & & 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.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 @@ -1654,17 +1654,17 @@ subroutine m_micro_run( 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,:) @@ -1672,14 +1672,14 @@ subroutine m_micro_run( 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) = 10.0d0 + CLDREFFI(I,k) = 50.0d0 + CLDREFFR(I,k) = 1000.0d0 + CLDREFFS(I,k) = 250.0d0 + CLDREFFG(I,k) = 250.0d0 enddo ! K loop endif endif @@ -1705,19 +1705,19 @@ subroutine m_micro_run( 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 @@ -1745,19 +1745,19 @@ subroutine m_micro_run( 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 @@ -1771,8 +1771,8 @@ subroutine m_micro_run( 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 @@ -1804,7 +1804,7 @@ subroutine m_micro_run( 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 @@ -1835,7 +1835,7 @@ subroutine m_micro_run( 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 @@ -1849,12 +1849,12 @@ subroutine m_micro_run( 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 @@ -1925,7 +1925,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 @@ -1941,15 +1941,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)) @@ -1961,7 +1961,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 @@ -1970,7 +1970,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 @@ -1993,7 +1993,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/physics/micro_mg_utils.F90 b/physics/micro_mg_utils.F90 index 89dd7193e..ec1843317 100644 --- a/physics/micro_mg_utils.F90 +++ b/physics/micro_mg_utils.F90 @@ -480,15 +480,15 @@ 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) 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 @@ -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)) @@ -705,14 +705,14 @@ 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) - 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 = 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 @@ -1094,12 +1094,12 @@ 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, 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))) @@ -2149,7 +2149,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)* & @@ -2201,7 +2201,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) @@ -2346,8 +2346,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) @@ -2710,10 +2710,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/physics/moninshoc.f b/physics/moninshoc.f index eb6ccd7e7..5bdf0ceef 100644 --- a/physics/moninshoc.f +++ b/physics/moninshoc.f @@ -91,20 +91,21 @@ subroutine moninshoc_run (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 :: 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 - &, dkmin=0.0, dkmax=1000. -! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 - &, prmin=0.25, prmax=4.0, vk=0.4, cfac=6.5 + real(kind=kind_phys), parameter :: one=1.0d0, zero=0.0d0 + &, 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 + &, dkmin=zero, dkmax=1000.0d0 +! &, dkmin=zero, dkmax=1000., xkzminv=0.3 + &, prmin=0.25d0, prmax=4.0d0, vk=0.4, cfac=6.5 real(kind=kind_phys) :: gravi, cont, conq, conw, gocp - gravi = 1.0/grav + gravi = one/grav cont = cp/grav conq = hvap/grav - conw = 1.0/grav + conw = one/grav gocp = grav/cp ! Initialize CCPP error handling variables @@ -122,7 +123,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, km1 = km - 1 kmpbl = km / 2 ! - rtg = 0.0 + rtg = zero ! do k=1,km do i=1,im @@ -137,24 +138,24 @@ subroutine moninshoc_run (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 @@ -165,9 +166,9 @@ subroutine moninshoc_run (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 @@ -176,21 +177,21 @@ subroutine moninshoc_run (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 @@ -205,7 +206,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! 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 ! @@ -220,11 +221,12 @@ subroutine moninshoc_run (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 @@ -243,9 +245,9 @@ subroutine moninshoc_run (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 @@ -270,11 +272,11 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, 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) + 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 @@ -292,7 +294,7 @@ subroutine moninshoc_run (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 @@ -304,9 +306,9 @@ subroutine moninshoc_run (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 @@ -344,19 +346,19 @@ subroutine moninshoc_run (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) endif ! -! prnum(i,kp1) = 1.0 +! prnum(i,kp1) = one prnum(i,kp1) = max(prmin, min(prmax, prnum(i,kp1))) tem = tkh(i,kp1) * prnum(i,kp1) dku(i,k) = max(min(tem+xkzmo(i,k), dkmax), xkzmo(i,k)) @@ -367,7 +369,7 @@ subroutine moninshoc_run (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 @@ -399,7 +401,7 @@ subroutine moninshoc_run (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 @@ -458,7 +460,7 @@ subroutine moninshoc_run (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 @@ -476,7 +478,7 @@ subroutine moninshoc_run (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) ! @@ -503,7 +505,7 @@ subroutine moninshoc_run (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 ! @@ -520,7 +522,7 @@ subroutine moninshoc_run (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 diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index 49d93e3fb..40d0ecb0d 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -13,34 +13,34 @@ module rascnv 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) & - &, facmb = 0.01 & ! conversion factor from Pa to hPa (or mb) - &, cmb2pa = 100.0 ! Conversion from hPa to Pa -! - real(kind=kind_phys), parameter :: frac=0.5, crtmsf=0.0 & - &, rhfacs=0.75, rhfacl=0.75 & - &, face=5.0, delx=10000.0 & - &, ddfac=face*delx*0.001 & - &, max_neg_bouy=0.15 & -! &, max_neg_bouy=pt25 & + 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.0d2, 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) & + &, facmb = 0.01d0 & ! conversion factor from Pa to hPa (or mb) + &, cmb2pa = 100.0d0 ! Conversion from hPa to Pa +! + real(kind=kind_phys), parameter :: frac=0.5d0, crtmsf=0.0d0 & + &, rhfacs=0.75d0, rhfacl=0.75d0 & + &, face=5.0d0, delx=10000.0d0 & + &, ddfac=face*delx*0.001d0 & + &, max_neg_bouy=0.15d0 & +! &, max_neg_bouy=pt25d0 & &, testmb=0.1, testmbi=one/testmb & - &, dpd=0.5, rknob=1.0, eknob=1.0 + &, dpd=0.5d0, rknob=1.0d0, eknob=1.0d0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! logical, parameter :: do_aw=.true., cumfrc=.true. & @@ -52,17 +52,17 @@ module rascnv ! &, advcld=.true., advups=.false.,advtvd=.false. - real(kind=kind_phys), parameter :: TF=233.16, TCR=273.16 & - &, TCRF=1.0/(TCR-TF), TCL=2.0 + real(kind=kind_phys), parameter :: TF=233.16d0, TCR=273.16d0 & + &, TCRF=one/(TCR-TF), TCL=2.0d0 ! ! 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 & - &, cfmax=0.1 + &, pgfgrad=(pgfbot-pgftop)*0.001d0& + &, cfmax=0.1d0 ! ! For Tilting Angle Specification ! @@ -167,7 +167,7 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & ! ! VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 ! - AFC = -(1.01097E-4*DT)*(3600./DT)**0.57777778 + AFC = -(1.01097d-4*DT)*(3600.0d0/DT)**0.57777778d0 ! grav = con_g ; cp = con_cp ; alhl = con_hvap alhf = con_hfus ; rgas = con_rd @@ -182,12 +182,12 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & rkap = rgas * onebcp ; deg2rad = pi/180.d0 ELOCP = ALHL * onebcp ; ELFOCP = (ALHL+ALHF) * onebcp oneoalhl = one/alhl ; CMPOR = CMB2PA / RGAS - picon = half*pi*onebg ; zfac = 0.28888889E-4 * ONEBG + picon = half*pi*onebg ; zfac = 0.28888889d-4 * ONEBG testmboalhl = testmb/alhl ! - rvi = one/rv ; facw=CVAP-CLIQ - faci = CVAP-CSOL ; hsub=alhl+alhf - tmix = TTP-20.0 ; DEN=one/(TTP-TMIX) + rvi = one/rv ; facw=CVAP-CLIQ + faci = CVAP-CSOL ; hsub=alhl+alhf + tmix = TTP-20.0d0 ; DEN=one/(TTP-TMIX) ! if (me == 0) write(0,*) ' NO DOWNDRAFT FOR CLOUD TYPES' & @@ -365,7 +365,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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(:,:) @@ -487,23 +487,23 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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) ! 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 @@ -513,7 +513,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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)) ! @@ -537,7 +537,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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 @@ -582,7 +582,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & if (ntr > 0) then ! tracers such as O3, dust etc do n=1,ntr 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 @@ -593,7 +593,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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) <= -998.0) then ! input ice/water are together do l=1,k ll = kp1 -l tem = ccin(ipt,ll,1) & @@ -631,7 +631,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & if (ntr > 0) then ! tracers such as O3, dust etc do n=1,ntr 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 @@ -641,7 +641,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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) <= -998.0) then ! input ice/water are together do l=1,k tem = ccin(ipt,l,1) & & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) @@ -688,7 +688,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! 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 @@ -702,7 +702,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! 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 @@ -713,7 +713,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! 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 @@ -724,7 +724,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! 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 @@ -741,7 +741,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! 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 @@ -850,7 +850,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & FLXD(L) = zero enddo ! - TLA = -10.0 + TLA = -10.0d0 ! qiid = qii(ib) ! cloud top level ice before convection qlid = qli(ib) ! cloud top level water before convection @@ -906,7 +906,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) ! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) + flx(ib)* & - & max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt + & max(zero,(QLI(ib)+QII(ib)-qiid-qlid))/dt ! & max(0.,(QLI(ib)+QII(ib)))/dt/3. if(flx(ib)<0) write(*,*)"AAA666", flx(ib),QLI(ib),QII(ib) & & ,ipt,ib @@ -930,7 +930,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! 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 ktop(ipt) = kp1 kbot(ipt) = 0 @@ -944,9 +944,9 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! 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 @@ -972,18 +972,18 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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 - 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)) 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 (ntr > 0) then @@ -1023,21 +1023,21 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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.d0*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 (ntr > 0) then @@ -1140,33 +1140,33 @@ SUBROUTINE CLOUD( & ! IMPLICIT NONE ! - real (kind=kind_phys), parameter :: RHMAX=1.0 & ! MAX RELATIVE HUMIDITY - &, QUAD_LAM=1.0 & ! MASK FOR QUADRATIC LAMBDA - &, RHRAM=0.05 & ! PBL RELATIVE HUMIDITY RAMP -! &, RHRAM=0.15 !& ! PBL RELATIVE HUMIDITY RAMP - &, HCRITD=4000.0 & ! Critical Moist Static Energy for Deep clouds - &, HCRITS=2000.0 & ! Critical Moist Static Energy for Shallow clouds - &, pcrit_lcl=250.0 & ! Critical pressure difference between boundary layer top - ! layer top and lifting condensation level (hPa) -! &, hpert_fac=1.01 !& ! Perturbation on hbl when ctei=.true. -! &, hpert_fac=1.005 !& ! Perturbation on hbl when ctei=.true. + real (kind=kind_phys), parameter :: RHMAX=1.0d0 & ! MAX RELATIVE HUMIDITY + &, QUAD_LAM=1.0d0 & ! MASK FOR QUADRATIC LAMBDA + &, RHRAM=0.05d0 & ! PBL RELATIVE HUMIDITY RAMP +! &, RHRAM=0.15d0 !& ! PBL RELATIVE HUMIDITY RAMP + &, HCRITD=4000.0d0 & ! Critical Moist Static Energy for Deep clouds + &, HCRITS=2000.0d0 & ! Critical Moist Static Energy for Shallow clouds + &, pcrit_lcl=250.0d0 & ! Critical pressure difference between boundary layer top + ! layer top and lifting condensation level (hPa) +! &, hpert_fac=1.01d0 !& ! Perturbation on hbl when ctei=.true. +! &, hpert_fac=1.005d0 !& ! Perturbation on hbl when ctei=.true. &, qudfac=quad_lam*half & - &, shalfac=3.0 & + &, shalfac=3.0d0 & ! &, qudfac=quad_lam*pt25, shalfac=3.0 !& ! Yogesh's - &, c0ifac=0.07 & ! following Han et al, 2016 MWR - &, dpnegcr = 150.0 -! &, dpnegcr = 100.0 -! &, dpnegcr = 200.0 -! - real(kind=kind_phys), parameter :: ERRMIN=0.0001 & - &, ERRMI2=0.1*ERRMIN & -! &, rainmin=1.0e-9 !& - &, rainmin=1.0e-8 & - &, oneopt9=1.0/0.09 & - &, oneopt4=1.0/0.04 - real(kind=kind_phys), parameter :: almax=1.0e-2 & - &, almin1=0.0, almin2=0.0 - real(kind=kind_phys), parameter :: bldmax = 300.0, bldmin=25.0 + &, c0ifac=0.07d0 & ! following Han et al, 2016 MWR + &, dpnegcr = 150.0d0 +! &, dpnegcr = 100.0d0 +! &, dpnegcr = 200.0d0 +! + real(kind=kind_phys), parameter :: ERRMIN=0.0001d0 & + &, ERRMI2=0.1d0*ERRMIN & +! &, rainmin=1.0d-9 !& + &, rainmin=1.0d-8 & + &, oneopt9=1.0d0/0.09d0 & + &, oneopt4=1.0d0/0.04d0 + real(kind=kind_phys), parameter :: almax=1.0d-2 & + &, almin1=0.0d0, almin2=0.0d0 + real(kind=kind_phys), parameter :: bldmax=300.0d0, bldmin=25.0d0 ! ! INPUT ARGUMENTS @@ -1371,8 +1371,14 @@ SUBROUTINE CLOUD( & ! To determine KBL internally -- If KBL is defined externally ! the following two loop should be skipped ! - hcrit = hcritd - if (sgcs(kd) > 0.65) hcrit = hcrits + if (sgcs(kd) < 0.5d0) then + hcrit = hcritd + elseif (sgcs(kd) > 0.65d0) then + hcrit = hcrits + else + hcrit = (hcrits*(sgcs(kd)-0.5d0) + hcritd*(0.65d0-sgcs(kd)))& + & * (one/0.15d0) + endif IF (CALKBL) THEN KTEM = MAX(KD+1, KBLMX) hmin = hol(k) @@ -1455,7 +1461,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 @@ -1515,7 +1521,7 @@ SUBROUTINE CLOUD( & ! 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) < 350.0d0 .and. kmax == k) shal_fac = shalfac DO L=Kmax,KD,-1 IF (L >= KBL) THEN ETA(L) = (PRL(Kmaxp1)-PRL(L)) * PRISM @@ -1577,7 +1583,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 @@ -1587,9 +1593,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) @@ -1602,9 +1608,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(two, max(wcbase, sqrt(twoo3*rbl(ntk)))) +! wcbase = min(one, max(wcbase, sqrt(twoo3*rbl(ntk)))) endif endif @@ -1665,7 +1671,7 @@ SUBROUTINE CLOUD( & QLL(KD ) = ALHF * GAF(KD) * QIL(KD) + ONE ! 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 ! @@ -1687,7 +1693,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 ! @@ -1746,13 +1752,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 !*********************************************************************** @@ -1769,7 +1775,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 @@ -1778,8 +1784,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) endif @@ -1850,12 +1856,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.0) + rel_fac = (dt * facdt) / (tem1*6.0d0 + tem2*adjts_s) else rel_fac = (dt * facdt) / (tem1*adjts_d + tem2*adjts_s) endif @@ -1864,7 +1870,7 @@ SUBROUTINE CLOUD( & rel_fac = max(zero, min(half,rel_fac)) IF (CRTFUN) THEN - iwk = tem*0.02-0.999999999 + iwk = tem*0.02d0 - 0.999999999d0 iwk = MAX(1, MIN(iwk, 16)) ACR = tx1 * (AC(iwk) + tem * AD(iwk)) * CCWF ENDIF @@ -2037,7 +2043,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. @@ -2080,7 +2086,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 (DDFT) THEN ! Downdraft scheme based on (Cheng and Arakawa, 1997) @@ -2395,7 +2401,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 / area) tx2 = tx2 * tx2 @@ -2519,8 +2525,8 @@ SUBROUTINE CLOUD( & endif enddo tem = tem + amb * dof * sigf(kbl) - tem = tem * (3600.0/dt) - tem1 = sqrt(max(one, min(100.0,(6.25E10/max(area,one))))) ! 20110530 + tem = tem * (3600.0d0/dt) + tem1 = sqrt(max(one, min(100.0d0,(6.25d10/max(area,one))))) ! 20110530 clfrac = max(ZERO, min(half, rknob*clf(tem)*tem1)) cldfrd = clfrac @@ -2567,7 +2573,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) @@ -2575,7 +2581,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) ! @@ -2644,7 +2650,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 @@ -2654,7 +2660,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 @@ -2773,7 +2779,7 @@ SUBROUTINE DDRFT( & &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1 & &, IDW, IDH, IDN(K), idnm, itr ! - 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, pio2=half*pi @@ -2783,8 +2789,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) @@ -2793,11 +2800,12 @@ SUBROUTINE DDRFT( & &, itrmin=15, itrmnd=12, numtla=2 ! uncentering for vvel in dd - real(kind=kind_phys), parameter :: ddunc1=0.25, ddunc2=one-ddunc1 & + real(kind=kind_phys), parameter :: ddunc1=0.25d0 & + &, ddunc2=one-ddunc1 & ! &, ddunc1=0.4, ddunc2=one-ddunc1 & ! &, ddunc1=0.3, ddunc2=one-ddunc1 & - &, VTPEXP=-0.3636 & - &, VTP=36.34*SQRT(1.2)*(0.001)**0.1364 + &, VTPEXP=-0.3636d0 & + &, VTP=36.34d0*SQRT(1.2d0)*(0.001d0)**0.1364d0 ! ! real(kind=kind_phys) EM(K*K), ELM(K) real(kind=kind_phys) ELM(K), AA(KD:K,KD:KP1), QW(KD:K,KD:K) & @@ -2822,7 +2830,7 @@ SUBROUTINE DDRFT( & CLDFRD = zero RNTP = zero DOF = zero - ERRQ = 10.0 + ERRQ = 10.0d0 RNB = zero RNT = zero TX2 = PRL(KBL) @@ -2853,7 +2861,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 ! @@ -2861,24 +2869,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 @@ -2939,15 +2947,15 @@ 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 CTL2 = one - STLA * STLA ! cosine square of tilting angle ! - 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 @@ -3010,7 +3018,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) @@ -3044,7 +3052,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 @@ -3115,7 +3123,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 @@ -3250,7 +3258,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 @@ -3273,17 +3281,17 @@ SUBROUTINE DDRFT( & ENDIF 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.1d0) THEN + IF (TEM < ZERO .AND. ERRQ > 0.5d0) THEN ! IF (TEM < ZERO .and. & -! & (ntla < numtla .or. ERRQ > 0.5)) THEN +! & (ntla < numtla .or. ERRQ > 0.5d0)) THEN 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! - 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 @@ -3301,7 +3309,7 @@ SUBROUTINE DDRFT( & ! ENDDO ! End of the ITR Loop!! ! - IF (ERRQ < 0.1) THEN + IF (ERRQ < 0.1d0) THEN DDFT = .TRUE. RNB = - RNB ! do l=kd1,kb1-1 @@ -3322,7 +3330,7 @@ SUBROUTINE DDRFT( & TX1 = TX1 + RNF(L) ENDDO TX1 = TRAIN / (TX1+RNT+RNB) - 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 @@ -3332,7 +3340,7 @@ SUBROUTINE DDRFT( & ELSE DDFT = .FALSE. - ERRQ = 10.0 + ERRQ = 10.0d0 ENDIF ENDIF ! @@ -3356,7 +3364,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) @@ -3402,9 +3410,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) @@ -3465,7 +3473,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! ! @@ -3473,7 +3481,7 @@ SUBROUTINE DDRFT( & HOD(L) = HOD(L-1) QOD(L) = QOD(L-1) ! - ERRQ = 10.0 + ERRQ = 10.0d0 ! IF (L <= KBL) THEN @@ -3498,7 +3506,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 @@ -3626,9 +3634,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) @@ -3639,7 +3647,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) ! @@ -3660,7 +3668,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 @@ -3687,7 +3695,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 @@ -3701,7 +3709,7 @@ SUBROUTINE DDRFT( & ! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN - IF (ETD(L-1) == zero .AND. ERRQ > 0.2) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.2d0) THEN ROR(L) = BUD(KD) ETD(L) = zero WVL(L) = zero @@ -3713,7 +3721,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 EVP(L-1) = zero @@ -3722,14 +3730,14 @@ SUBROUTINE DDRFT( & ! IF (QA(1) > 0.0) THEN 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 @@ -3756,9 +3764,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)) @@ -3769,7 +3777,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) ! @@ -3822,7 +3830,7 @@ 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) @@ -3845,7 +3853,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 @@ -3876,7 +3884,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 @@ -3980,7 +3988,7 @@ SUBROUTINE QSATCN(TT,P,Q,DQDT) 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 = min(p, 0.01d0 * fpvs(tt)) ! fpvs is in Pascals! ! D = one / max(p+epsm1*es,ONE_M10) D = one / (p+epsm1*es) ! @@ -4001,7 +4009,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 @@ -4038,8 +4046,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 subroutine angrad @@ -4051,18 +4059,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 @@ -4087,12 +4095,12 @@ end subroutine qrabf SUBROUTINE SETVTP implicit none - real(kind=kind_phys), parameter :: vtpexp=-0.3636, one=1.0 + real(kind=kind_phys), parameter :: vtpexp=-0.3636d0, one=1.0d0 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 @@ -4139,10 +4147,10 @@ real(kind=kind_phys) FUNCTION CLF(PRATE) implicit none real(kind=kind_phys) PRATE ! - 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/physics/sfc_cice.f b/physics/sfc_cice.f index d0aaee476..9cb2b5f21 100644 --- a/physics/sfc_cice.f +++ b/physics/sfc_cice.f @@ -127,21 +127,21 @@ subroutine sfc_cice_run & ! if (.not. cplflx) return ! - cpinv = 1.0/cp - hvapi = 1.0/hvap + cpinv = 1.0d0/cp + hvapi = 1.0d0/hvap elocp = hvap/cp ! do i = 1, im if (flag_cice(i) .and. flag_iter(i)) then rho = prsl1(i) & - & / (rd * t1(i) * (1.0 + rvrdm1*max(q1(i), 1.0e-8))) + & / (rd * t1(i) * (1.0d0 + rvrdm1*max(q1(i), 1.0d-8))) cmm(i) = wind(i) * cm(i) chh(i) = wind(i) * ch(i) * rho qsurf(i) = q1(i) + dqsfc(i) / (hvap*chh(i)) - tem = 1.0 / rho + tem = 1.0d0 / rho hflx(i) = dtsfc(i) * tem * cpinv evap(i) = dqsfc(i) * tem * hvapi stress(i) = sqrt(dusfc(i)*dusfc(i) + dvsfc(i)*dvsfc(i)) * tem diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 60d5ceeea..f15e20d53 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -14,7 +14,7 @@ module sfc_diff private - real (kind=kind_phys), parameter :: ca=.4 ! ca - von karman constant + real (kind=kind_phys), parameter :: ca=0.4d0 ! ca - von karman constant contains @@ -128,9 +128,11 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) real(kind=kind_phys) :: tvs, z0, z0max, ztmax ! real(kind=kind_phys), parameter :: - & charnock=.014, z0s_max=.317e-2 &! a limiting value at high winds over sea - &, vis=1.4e-5, rnu=1.51e-5, visi=1.0/vis & - &, log01=log(0.01), log05=log(0.05), log07=log(0.07) + & one=1.0d0, zero=0.0d0, half=0.5d0, qmin=1.0d-8 + &, charnock=.014d0, z0s_max=.317d-2 &! a limiting value at high winds over sea + &, zmin=1.0d-6 & + &, vis=1.4d-5, rnu=1.51d-5, visi=one/vis & + &, log01=log(0.01d0), log05=log(0.05d0), log07=log(0.07d0) ! parameter (charnock=.014,ca=.4)!c ca is the von karman constant ! parameter (alpha=5.,a0=-3.975,a1=12.32,b1=-7.755,b2=6.041) @@ -161,7 +163,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) do i=1,im if(flag_iter(i)) then - virtfac = 1.0 + rvrdm1 * max(q1(i),1.e-8) + virtfac = one + rvrdm1 * max(q1(i),qmin) thv1 = t1(i) * prslki(i) * virtfac ! compute stability dependent exchange coefficients @@ -169,15 +171,16 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! if (dry(i)) then ! Some land #ifdef GSD_SURFACE_FLUXES_BUGFIX - tvs = 0.5 * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) * virtfac + tvs = half * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) + & * virtfac #else - tvs = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) * virtfac + tvs = half * (tsurf_lnd(i)+tskin_lnd(i)) * virtfac #endif - z0max = max(1.0e-6, min(0.01 * z0rl_lnd(i), z1(i))) + z0max = max(zmin, min(0.01d0 * z0rl_lnd(i), z1(i))) !** xubin's new z0 over land - tem1 = 1.0 - shdmax(i) + tem1 = one - shdmax(i) tem2 = tem1 * tem1 - tem1 = 1.0 - tem2 + tem1 = one - tem2 if( ivegsrc == 1 ) then @@ -187,10 +190,10 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = exp( tem2*log01 + tem1*log05 ) elseif (vegtype(i) == 7) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01d0 elseif (vegtype(i) == 16) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01d0 else z0max = exp( tem2*log01 + tem1*log(z0max) ) endif @@ -203,35 +206,35 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = exp( tem2*log01 + tem1*log05 ) elseif (vegtype(i) == 9) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01d0 elseif (vegtype(i) == 11) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01d0 else z0max = exp( tem2*log01 + tem1*log(z0max) ) endif endif ! mg, sfc-perts: add surface perturbations to z0max over land - if (z0pert(i) /= 0.0 ) then - z0max = z0max * (10.**z0pert(i)) + if (z0pert(i) /= zero ) then + z0max = z0max * (10.0d0**z0pert(i)) endif - z0max = max(z0max, 1.0e-6) + z0max = max(z0max, zmin) ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil - czilc = 0.8 + czilc = 0.8d0 - tem1 = 1.0 - sigmaf(i) + tem1 = one - sigmaf(i) ztmax = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) + & * czilc*ca*sqrt(ustar_lnd(i)*(0.01d0/1.5d-05))) ! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land - if (ztpert(i) /= 0.0) then - ztmax = ztmax * (10.**ztpert(i)) + if (ztpert(i) /= zero) then + ztmax = ztmax * (10.0d0**ztpert(i)) endif - ztmax = max(ztmax, 1.0e-6) + ztmax = max(ztmax, zmin) ! call stability ! --- inputs: @@ -243,12 +246,12 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) endif ! Dry points if (icy(i)) then ! Some ice - tvs = 0.5 * (tsurf_ice(i)+tskin_ice(i)) * virtfac - z0max = max(1.0e-6, min(0.01 * z0rl_ice(i), z1(i))) + tvs = half * (tsurf_ice(i)+tskin_ice(i)) * virtfac + z0max = max(zmin, min(0.01d0 * z0rl_ice(i), z1(i))) !** xubin's new z0 over land and sea ice - tem1 = 1.0 - shdmax(i) + tem1 = one - shdmax(i) tem2 = tem1 * tem1 - tem1 = 1.0 - tem2 + tem1 = one - tem2 if( ivegsrc == 1 ) then @@ -257,16 +260,16 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = exp( tem2*log01 + tem1*log(z0max) ) endif - z0max = max(z0max, 1.0e-6) + z0max = max(z0max, zmin) ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height ! dependance of czil - czilc = 0.8 + czilc = 0.8d0 - tem1 = 1.0 - sigmaf(i) + tem1 = one - sigmaf(i) ztmax = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) - ztmax = max(ztmax, 1.0e-6) + & * czilc*ca*sqrt(ustar_ice(i)*(0.01d0/1.5d-05))) + ztmax = max(ztmax, zmin) ! call stability ! --- inputs: @@ -281,9 +284,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! the stuff now put into "stability" if (wet(i)) then ! Some open ocean - tvs = 0.5 * (tsurf_ocn(i)+tskin_ocn(i)) * virtfac - z0 = 0.01 * z0rl_ocn(i) - z0max = max(1.0e-6, min(z0,z1(i))) + tvs = half * (tsurf_ocn(i)+tskin_ocn(i)) * virtfac + z0 = 0.01d0 * z0rl_ocn(i) + z0max = max(zmin, min(z0,z1(i))) ustar_ocn(i) = sqrt(grav * z0 / charnock) wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) @@ -291,7 +294,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ztmax = z0max - restar = max(ustar_ocn(i)*z0max*visi, 0.000001) + restar = max(ustar_ocn(i)*z0max*visi, 0.000001d0) ! restar = log(restar) ! restar = min(restar,5.) @@ -300,8 +303,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! rat = rat / (1. + (bb2 + cc2*restar) * restar)) ! rat taken from zeng, zhao and dickinson 1997 - rat = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57) - ztmax = max(z0max * exp(-rat), 1.0e-6) + rat = min(7.0d0, 2.67d0 * sqrt(sqrt(restar)) - 2.57d0) + ztmax = max(z0max * exp(-rat), zmin) ! if (sfc_z0_type == 6) then call znot_t_v6(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) @@ -335,19 +338,19 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! z0 = arnu / (ustar(i) * ff ** pp) if (redrag) then - z0rl_ocn(i) = 100.0 * max(min(z0, z0s_max), 1.e-7) + z0rl_ocn(i) = 100.0d0 * max(min(z0, z0s_max), 1.d-7) else - z0rl_ocn(i) = 100.0 * max(min(z0,.1), 1.e-7) + z0rl_ocn(i) = 100.0d0 * max(min(z0,.1d0), 1.d-7) endif elseif (sfc_z0_type == 6) then ! wang call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m - z0rl_ocn(i) = 100.0 * z0 ! cm + z0rl_ocn(i) = 100.0d0 * z0 ! cm elseif (sfc_z0_type == 7) then ! wang call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m - z0rl_ocn(i) = 100.0 * z0 ! cm + z0rl_ocn(i) = 100.0d0 * z0 ! cm else - z0rl_ocn(i) = 1.0e-4 + z0rl_ocn(i) = 1.0d-4 endif endif @@ -378,11 +381,12 @@ subroutine stability & & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar ! --- locals: - real(kind=kind_phys), parameter :: alpha=5., a0=-3.975 & - &, a1=12.32, alpha4=4.0*alpha - &, b1=-7.755, b2=6.041, alpha2=alpha+alpha, beta=1.0 - &, a0p=-7.941, a1p=24.75, b1p=-8.705, b2p=7.899 - &, ztmin1=-999.0 + real(kind=kind_phys), parameter :: alpha=5.0d0, a0=-3.975d0 & + &, 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& + &, ztmin1=-999.0d0, zero=0.0d0, one=1.0d0 real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, & hl1, hl12, pm, ph, pm10, ph2, @@ -391,51 +395,51 @@ subroutine stability & & hl110, hlt, hltinf, olinf, & tem1, tem2, ztmax1 - z1i = 1.0 / z1 + z1i = one / z1 tem1 = z0max/z1 - if (abs(1.0-tem1) > 1.0e-6) then - ztmax1 = - beta*log(tem1)/(alpha2*(1.-tem1)) + if (abs(one-tem1) > 1.0d-6) then + ztmax1 = - beta*log(tem1)/(alpha2*(one-tem1)) else - ztmax1 = 99.0 + ztmax1 = 99.0d0 endif - if( z0max < 0.05 .and. snwdph < 10.0 ) ztmax1 = 99.0 + if( z0max < 0.05d0 .and. snwdph < 10.0d0 ) ztmax1 = 99.0d0 ! compute stability indices (rb and hlinf) dtv = thv1 - tvs - adtv = max(abs(dtv),0.001) + adtv = max(abs(dtv),0.001d0) dtv = sign(1.,dtv) * adtv #ifdef GSD_SURFACE_FLUXES_BUGFIX - rb = max(-5000.0, grav * dtv * z1 + rb = max(-5000.0d0, grav * dtv * z1 & / (thv1 * wind * wind)) #else - rb = max(-5000.0, (grav+grav) * dtv * z1 + rb = max(-5000.0d0, (grav+grav) * dtv * z1 & / ((thv1 + tvs) * wind * wind)) #endif - tem1 = 1.0 / z0max - tem2 = 1.0 / ztmax + tem1 = one / z0max + tem2 = one / ztmax fm = log((z0max+z1) * tem1) fh = log((ztmax+z1) * tem2) - fm10 = log((z0max+10.) * tem1) - fh2 = log((ztmax+2.) * tem2) + fm10 = log((z0max+10.0d0) * tem1) + fh2 = log((ztmax+2.0d0) * tem2) hlinf = rb * fm * fm / fh hlinf = min(max(hlinf,ztmin1),ztmax1) ! ! stable case ! - if (dtv >= 0.0) then + if (dtv >= zero) then hl1 = hlinf - if(hlinf > .25) then + if(hlinf > 0.25d0) then tem1 = hlinf * z1i hl0inf = z0max * tem1 hltinf = ztmax * tem1 - aa = sqrt(1. + alpha4 * hlinf) - aa0 = sqrt(1. + alpha4 * hl0inf) + aa = sqrt(one + alpha4 * hlinf) + aa0 = sqrt(one + alpha4 * hl0inf) bb = aa - bb0 = sqrt(1. + alpha4 * hltinf) - pm = aa0 - aa + log( (aa + 1.)/(aa0 + 1.) ) - ph = bb0 - bb + log( (bb + 1.)/(bb0 + 1.) ) + bb0 = sqrt(one + alpha4 * hltinf) + pm = aa0 - aa + log( (aa + one)/(aa0 + one) ) + ph = bb0 - bb + log( (bb + one)/(bb0 + one) ) fms = fm - pm fhs = fh - ph hl1 = fms * fms * rb / fhs @@ -447,27 +451,27 @@ subroutine stability & tem1 = hl1 * z1i hl0 = z0max * tem1 hlt = ztmax * tem1 - aa = sqrt(1. + alpha4 * hl1) - aa0 = sqrt(1. + alpha4 * hl0) + aa = sqrt(one + alpha4 * hl1) + aa0 = sqrt(one + alpha4 * hl0) bb = aa - bb0 = sqrt(1. + alpha4 * hlt) - pm = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) - ph = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) - hl110 = hl1 * 10. * z1i + bb0 = sqrt(one + alpha4 * hlt) + pm = aa0 - aa + log( (one+aa)/(one+aa0) ) + ph = bb0 - bb + log( (one+bb)/(one+bb0) ) + hl110 = hl1 * 10.0d0 * z1i hl110 = min(max(hl110, ztmin1), ztmax1) - aa = sqrt(1. + alpha4 * hl110) - pm10 = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) + aa = sqrt(one + alpha4 * hl110) + pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) hl12 = (hl1+hl1) * z1i hl12 = min(max(hl12,ztmin1),ztmax1) -! aa = sqrt(1. + alpha4 * hl12) - bb = sqrt(1. + alpha4 * hl12) - ph2 = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) +! aa = sqrt(one + alpha4 * hl12) + bb = sqrt(one + alpha4 * hl12) + ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) ! ! unstable case - check for unphysical obukhov length ! else ! dtv < 0 case olinf = z1 / hlinf - tem1 = 50.0 * z0max + tem1 = 50.0d0 * z0max if(abs(olinf) <= tem1) then hlinf = -z1 / tem1 hlinf = min(max(hlinf,ztmin1),ztmax1) @@ -475,30 +479,30 @@ subroutine stability & ! ! get pm and ph ! - if (hlinf >= -0.5) then + if (hlinf >= -0.5d0) then hl1 = hlinf - pm = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) - ph = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) - hl110 = hl1 * 10. * z1i + pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) + ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) + hl110 = hl1 * 10.0d0 * z1i hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = (a0 + a1*hl110) * hl110 / (1.+(b1+b2*hl110)*hl110) + pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) hl12 = (hl1+hl1) * z1i hl12 = min(max(hl12, ztmin1), ztmax1) - ph2 = (a0p + a1p*hl12) * hl12 / (1.+(b1p+b2p*hl12)*hl12) + ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) else ! hlinf < 0.05 hl1 = -hlinf - tem1 = 1.0 / sqrt(hl1) - pm = log(hl1) + 2. * sqrt(tem1) - .8776 - ph = log(hl1) + .5 * tem1 + 1.386 + tem1 = one / sqrt(hl1) + pm = log(hl1) + 2.0d0 * sqrt(tem1) - .8776d0 + ph = log(hl1) + 0.5d0 * tem1 + 1.386d0 ! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 ! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 - hl110 = hl1 * 10. * z1i + hl110 = hl1 * 10.0d0 * z1i hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = log(hl110) + 2.0 / sqrt(sqrt(hl110)) - .8776 + pm10 = log(hl110) + 2.0d0 / sqrt(sqrt(hl110)) - 0.8776d0 ! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 hl12 = (hl1+hl1) * z1i hl12 = min(max(hl12, ztmin1), ztmax1) - ph2 = log(hl12) + 0.5 / sqrt(hl12) + 1.386 + ph2 = log(hl12) + 0.5d0 / sqrt(hl12) + 1.386d0 ! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 endif @@ -512,7 +516,7 @@ subroutine stability & fh2 = fh2 - ph2 cm = ca * ca / (fm * fm) ch = ca * ca / (fm * fh) - tem1 = 0.00001/z1 + tem1 = 0.00001d0/z1 cm = max(cm, tem1) ch = max(ch, tem1) stress = cm * wind * wind diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index 75afaa6ff..9f2170e80 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -194,14 +194,16 @@ subroutine lsm_noah_run & implicit none ! --- constant parameters: - 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 :: one = 1.0d0, zero = 0.0d0 + 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 @@ -266,9 +268,9 @@ subroutine lsm_noah_run & ! !===> ... begin here ! - cpinv = 1.0/cp - hvapi = 1.0/hvap - elocp = hvap/cp + cpinv = one/cp + hvapi = one/hvap + elocp = hvap/cp !> - Initialize CCPP error handling variables @@ -298,19 +300,19 @@ subroutine lsm_noah_run & do i = 1, im if (flag_iter(i) .and. land(i)) then - ep(i) = 0.0 - evap (i) = 0.0 - hflx (i) = 0.0 - gflux(i) = 0.0 - drain(i) = 0.0 - canopy(i) = max(canopy(i), 0.0) - - evbs (i) = 0.0 - evcw (i) = 0.0 - trans(i) = 0.0 - sbsno(i) = 0.0 - snowc(i) = 0.0 - snohf(i) = 0.0 + ep(i) = zero + evap (i) = zero + hflx (i) = zero + gflux(i) = zero + drain(i) = zero + canopy(i) = max(canopy(i), zero) + + evbs (i) = zero + evcw (i) = zero + trans(i) = zero + sbsno(i) = zero + snowc(i) = zero + snohf(i) = zero endif ! flag_iter & land enddo @@ -318,12 +320,12 @@ subroutine lsm_noah_run & do i = 1, im if (flag_iter(i) .and. land(i)) then - q0(i) = max(q1(i), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) + q0(i) = max(q1(i), qmin) !* q1=specific humidity at level 1 (kg/kg) theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) - rho(i) = prsl1(i) / (rd*t1(i)*(1.0+rvrdm1*q0(i))) + rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0(i))) qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) - qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), 1.e-8) + qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), qmin) q0 (i) = min(qs1(i), q0(i)) endif ! flag_iter & land enddo @@ -422,12 +424,12 @@ subroutine lsm_noah_run & !! 0.5 and the perturbations go to zero as vegetation fraction approaches its upper !! or lower bound. vegfp = vegfpert(i) ! sfc-perts, mgehne - if (pertvegf(1)>0.0) then + if (pertvegf(1) > zero) then ! compute beta distribution parameters for vegetation fraction mv = shdfac sv = pertvegf(1)*mv*(1.-mv) - alphav = mv*mv*(1.0-mv)/(sv*sv)-mv - betav = alphav*(1.0-mv)/mv + alphav = mv*mv*(one-mv)/(sv*sv)-mv + betav = alphav*(one-mv)/mv ! compute beta distribution value corresponding ! to the given percentile albPpert to use as new albedo call ppfbet(vegfp,alphav,betav,iflag,vegftmp) @@ -439,7 +441,7 @@ subroutine lsm_noah_run & shdmax1d = shdmax(i) snoalb1d = snoalb(i) - ptu = 0.0 + ptu = zero alb = sfalb(i) tbot = tg3(i) @@ -456,7 +458,7 @@ subroutine lsm_noah_run & ! cm - surface exchange coefficient for momentum (\f$m s^{-1}\f$) -> cmx ! z0 - surface roughness (\f$m\f$) -> zorl(\f$cm\f$) - cmc = canopy(i) * 0.001 ! convert from mm to m + cmc = canopy(i) * 0.001d0 ! convert from mm to m tsea = tsurf(i) ! clu_q2m_iter do k = 1, km @@ -465,10 +467,10 @@ subroutine lsm_noah_run & slsoil(k) = slc(i,k) enddo - snowh = snwdph(i) * 0.001 ! convert from mm to m - sneqv = weasd(i) * 0.001 ! convert from mm to m - if (sneqv /= 0.0 .and. snowh == 0.0) then - snowh = 10.0 * sneqv + snowh = snwdph(i) * 0.001d0 ! convert from mm to m + sneqv = weasd(i) * 0.001d0 ! convert from mm to m + if (sneqv /= zero .and. snowh == zero) then + snowh = 10.0d0 * sneqv endif chx = ch(i) * wind(i) ! compute conductance @@ -477,7 +479,7 @@ subroutine lsm_noah_run & cmm(i) = cmx ! ---- ... outside sflx, roughness uses cm as unit - z0 = zorl(i)/100. + z0 = zorl(i) * 0.01d0 ! ---- mgehne, sfc-perts ! - Apply perturbation of soil type b parameter and leave area index. bexpp = bexppert(i) ! sfc perts, mgehne @@ -522,7 +524,7 @@ subroutine lsm_noah_run & trans(i) = ett sbsno(i) = esnow snowc(i) = sncovr - stm(i) = soilm * 1000.0 ! unit conversion (from m to kg m-2) + stm(i) = soilm * 1000.0d0 ! unit conversion (from m to kg m-2) snohf(i) = flx1 + flx2 + flx3 smcwlt2(i) = smcwlt @@ -539,17 +541,17 @@ subroutine lsm_noah_run & wet1(i) = smsoil(1) / smcmax !Sarah Lu added 09/09/2010 (for GOCART) ! --- ... unit conversion (from m s-1 to mm s-1 and kg m-2 s-1) - runoff(i) = runoff1 * 1000.0 - drain (i) = runoff2 * 1000.0 + runoff(i) = runoff1 * 1000.0d0 + drain (i) = runoff2 * 1000.0d0 ! --- ... unit conversion (from m to mm) - canopy(i) = cmc * 1000.0 - snwdph(i) = snowh * 1000.0 - weasd(i) = sneqv * 1000.0 + canopy(i) = cmc * 1000.0d0 + snwdph(i) = snowh * 1000.0d0 + weasd(i) = sneqv * 1000.0d0 sncovr1(i) = sncovr ! ---- ... outside sflx, roughness uses cm as unit (update after snow's ! effect) - zorl(i) = z0*100. + zorl(i) = z0*100.0d0 !> - Do not return the following output fields to parent model: !!\n ec - canopy water evaporation (m s-1) @@ -606,7 +608,7 @@ subroutine lsm_noah_run & !! flux (\a evap). do i = 1, im if (flag_iter(i) .and. land(i)) then - tem = 1.0 / rho(i) + tem = one / rho(i) hflx(i) = hflx(i) * tem * cpinv evap(i) = evap(i) * tem * hvapi endif ! flag_iter & land diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 9635f30b8..ba0aec030 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -23,7 +23,7 @@ end subroutine sfc_ocean_finalize subroutine sfc_ocean_run & !................................... ! --- inputs: - & ( im, cp, rd, eps, epsm1, hvap, rvrdm1, ps, t1, q1, & + & ( im, rd, eps, epsm1, rvrdm1, ps, t1, q1, & & tskin, cm, ch, prsl1, prslki, wet, wind, & & flag_iter, & ! --- outputs: @@ -90,10 +90,12 @@ subroutine sfc_ocean_run & ! implicit none +! --- constant parameters: + real (kind=kind_phys), parameter :: one = 1.0d0, zero = 0.0d0 & + &, qmin = 1.0d-8 ! --- inputs: integer, intent(in) :: im - real (kind=kind_phys), intent(in) :: cp, rd, eps, epsm1, hvap, & - & rvrdm1 + real (kind=kind_phys), intent(in) :: rd, eps, epsm1, rvrdm1 real (kind=kind_phys), dimension(im), intent(in) :: ps, & & t1, q1, tskin, cm, ch, prsl1, prslki, wind @@ -109,17 +111,11 @@ subroutine sfc_ocean_run & ! --- locals: - real (kind=kind_phys) :: q0, qss, rch, rho, tem, cpinv, & - & hvapi, elocp + real (kind=kind_phys) :: q0, qss, rch, rho, tem integer :: i - logical :: flag(im) -! !===> ... begin here - cpinv = 1.0/cp - hvapi = 1.0/hvap - elocp = hvap/cp ! ! -- ... initialize CCPP error handling variables errmsg = '' @@ -127,40 +123,32 @@ subroutine sfc_ocean_run & ! ! --- ... 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 - q0 = max( q1(i), 1.0e-8 ) - rho = prsl1(i) / (rd*t1(i)*(1.0 + rvrdm1*q0)) + if (wet(i) .and. flag_iter(i)) then + q0 = max( q1(i), qmin ) + rho = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0)) qss = fpvs( tskin(i) ) qss = eps*qss / (ps(i) + epsm1*qss) - evap(i) = 0.0 - hflx(i) = 0.0 - ep(i) = 0.0 - gflux(i) = 0.0 - ! --- ... rcp = rho cp ch v - rch = rho * cp * ch(i) * wind(i) + tem = ch(i) * wind(i) cmm(i) = cm(i) * wind(i) - chh(i) = rho * ch(i) * wind(i) + chh(i) = rho * tem ! --- ... sensible and latent heat flux over open water - hflx(i) = rch * (tskin(i) - t1(i) * prslki(i)) + hflx(i) = tem * (tskin(i) - t1(i) * prslki(i)) - evap(i) = elocp*rch * (qss - q0) - qsurf(i) = qss + evap(i) = tem * (qss - q0) - tem = 1.0 / rho - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi + ep(i) = evap(i) + qsurf(i) = qss endif enddo ! diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index d60c1ce2c..096454f7a 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -19,15 +19,6 @@ type = integer intent = in optional = F -[cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [rd] standard_name = gas_constant_dry_air long_name = ideal gas constant for dry air @@ -55,15 +46,6 @@ kind = kind_phys intent = in optional = F -[hvap] - standard_name = latent_heat_of_vaporization_of_water_at_0C - long_name = latent heat of evaporation/sublimation - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [rvrdm1] standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 750a6d795..db483ee75 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -146,6 +146,7 @@ subroutine sfc_sice_run & 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 ! --- inputs: integer, intent(in) :: im, km, ipr @@ -231,7 +232,7 @@ subroutine sfc_sice_run & 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 @@ -260,7 +261,7 @@ subroutine sfc_sice_run & ! dlwflx has been given a negative sign for downward longwave ! sfcnsw is the net shortwave flux (direction: dn-up) - q0 = max(q1(i), 1.0e-8) + q0 = max(q1(i), qmin) ! tsurf(i) = tskin(i) #ifdef GSD_SURFACE_FLUXES_BUGFIX theta1(i) = t1(i) / prslk1(i) ! potential temperature in middle of lowest atm. layer @@ -269,7 +270,7 @@ subroutine sfc_sice_run & #endif rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) qs1 = fpvs(t1(i)) - qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), 1.e-8) + qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) q0 = min(qs1, q0) if (fice(i) < cimin) then @@ -279,7 +280,7 @@ subroutine sfc_sice_run & tskin(i)= tgice print *,'fix ice fraction: reset it to:', fice(i) endif - ffw(i) = 1.0 - fice(i) + ffw(i) = one - fice(i) qssi = fpvs(tice(i)) qssi = eps*qssi / (ps(i) + epsm1*qssi) @@ -309,7 +310,7 @@ subroutine sfc_sice_run & ! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) snetw(i) = sfcdsw(i) * (one - albfw) - snetw(i) = min(3.0*sfcnsw(i)/(one+2.0d0*ffw(i)), snetw(i)) + snetw(i) = min(3.0d0*sfcnsw(i)/(one+2.0d0*ffw(i)), snetw(i)) !> - Calculate net solar incoming at top \a sneti. sneti(i) = (sfcnsw(i) - ffw(i)*snetw(i)) / fice(i) @@ -416,10 +417,10 @@ subroutine sfc_sice_run & ! --- ... convert snow depth back to mm of water equivalent - weasd(i) = snowd(i) * 1000.0 + weasd(i) = snowd(i) * 1000.0d0 snwdph(i) = weasd(i) * dsi ! snow depth in mm - tem = 1.0 / rho(i) + tem = one / rho(i) hflx(i) = hflx(i) * tem * cpinv evap(i) = evap(i) * tem * hvapi endif @@ -530,7 +531,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 @@ -573,9 +574,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 c316f79bfb86630513d460a898ca59d897406f90 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 21 Apr 2020 01:40:22 +0000 Subject: [PATCH 06/30] removing some unneeded do loops in sfc_drv.f - results reproduce --- physics/sfc_drv.f | 24 +++--------------------- 1 file changed, 3 insertions(+), 21 deletions(-) diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index 9f2170e80..f52b6d829 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -313,13 +313,9 @@ subroutine lsm_noah_run & sbsno(i) = zero snowc(i) = zero snohf(i) = zero - endif ! flag_iter & land - enddo !> - initialize variables wind, q, and rh at level 1. - do i = 1, im - if (flag_iter(i) .and. land(i)) then q0(i) = max(q1(i), qmin) !* q1=specific humidity at level 1 (kg/kg) theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) @@ -327,19 +323,10 @@ subroutine lsm_noah_run & qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), qmin) q0 (i) = min(qs1(i), q0(i)) - endif ! flag_iter & land - enddo - do i = 1, im - if (flag_iter(i) .and. land(i)) then do k = 1, km zsoil(i,k) = zsoil_noah(k) enddo - endif ! flag_iter & land - enddo - - do i = 1, im - if (flag_iter(i) .and. land(i)) then !> - Prepare variables to run Noah LSM: !! - 1. configuration information (c): @@ -592,25 +579,20 @@ subroutine lsm_noah_run & !!\n nroot - number of root layers, a function of veg type, determined !! in subroutine redprm. - endif ! end if flag_iter and flag - enddo ! end do_i_loop +! endif ! end if flag_iter and flag +! enddo ! end do_i_loop !> - Compute specific humidity at surface (\a qsurf). - do i = 1, im - if (flag_iter(i) .and. land(i)) then rch(i) = rho(i) * cp * ch(i) * wind(i) qsurf(i) = q1(i) + evap(i) / (elocp * rch(i)) - endif ! flag_iter & land - enddo !> - Compute surface upward sensible heat flux (\a hflx) and evaporation !! flux (\a evap). - do i = 1, im - if (flag_iter(i) .and. land(i)) then tem = one / rho(i) hflx(i) = hflx(i) * tem * cpinv evap(i) = evap(i) * tem * hvapi + endif ! flag_iter & land enddo From 5953c522b25ebc8a4424fbb54c4df21b4f38834d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 22 Apr 2020 01:32:06 +0000 Subject: [PATCH 07/30] updating precision of constants in several physics routines --- physics/GFS_MP_generic.F90 | 16 +-- physics/GFS_suite_interstitial.F90 | 77 +++++----- physics/GFS_surface_composites.F90 | 10 +- physics/GFS_surface_generic.F90 | 39 +++-- physics/m_micro.F90 | 223 +++++++++++++++-------------- physics/micro_mg3_0.F90 | 19 ++- physics/moninshoc.f | 40 +++--- physics/sfc_drv.f | 42 +++--- physics/sfc_ocean.F | 4 +- physics/sfc_sice.f | 76 +++++----- 10 files changed, 277 insertions(+), 269 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index bcf11db66..ffbe6ab9b 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -140,15 +140,15 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt integer, intent(out) :: errflg ! DH* TODO: CLEANUP, all of these should be coming in through the argument list - real(kind=kind_phys), parameter :: con_p001= 0.001d0 - real(kind=kind_phys), parameter :: con_day = 86400.0d0 - real(kind=kind_phys), parameter :: rainmin = 1.0d-13 - real(kind=kind_phys), parameter :: p850 = 85000.0d0 + 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 :: rainmin = 1.0e-13_kind_phys + real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys ! *DH integer :: i, k, ic - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2 real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 @@ -267,7 +267,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt do i = 1, im !tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp ! DH now lines 245-250 srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (tsfc(i) >= 273.15d0) then + if (tsfc(i) >= 273.15_kind_phys) then crain = rainc(i) csnow = zero else @@ -295,7 +295,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt if (rain(i) > rainmin) then tem1 = max(zero, (rain(i)-rainc(i))) * sr(i) tem2 = one / rain(i) - if (t850(i) > 273.16d0) then + if (t850(i) > 273.16_kind_phys) then srflag(i) = max(zero, min(one, tem1*tem2)) else srflag(i) = max(zero, min(one, (tem1+rainc(i))*tem2)) @@ -311,7 +311,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt do i = 1, im tprcp(i) = max(zero, rain(i) ) ! clu: rain -> tprcp srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16d0) then + if (t850(i) <= 273.16_kind_phys) then srflag(i) = one ! clu: set srflag to 'snow' (i.e. 1) endif enddo diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index a8d5f5b8b..f6c4c5c7a 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -100,6 +100,7 @@ subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, real(kind=kind_phys), intent(out), dimension(im) :: work1, work2, psurf real(kind=kind_phys), intent(out), dimension(im,levs) :: dudt, dvdt, dtdt, dtdtc real(kind=kind_phys), intent(out), dimension(im,levs,ntrac) :: dqdt + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -114,23 +115,23 @@ subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, islmsk(i) = nint(slmsk(i)) work1(i) = (log(area(i)) - dxmin) * dxinv - work1(i) = max(0.0, min(1.0,work1(i))) - work2(i) = 1.0 - work1(i) + work1(i) = max(zero, min(one, work1(i))) + work2(i) = one - work1(i) psurf(i) = pgr(i) end do do k=1,levs do i=1,im - dudt(i,k) = 0. - dvdt(i,k) = 0. - dtdt(i,k) = 0. - dtdtc(i,k) = 0. + dudt(i,k) = zero + dvdt(i,k) = zero + dtdt(i,k) = zero + dtdtc(i,k) = zero enddo enddo do n=1,ntrac do k=1,levs do i=1,im - dqdt(i,k,n) = 0. + dqdt(i,k,n) = zero enddo enddo enddo @@ -143,7 +144,6 @@ end module GFS_suite_interstitial_1 module GFS_suite_interstitial_2 use machine, only: kind_phys - real(kind=kind_phys), parameter :: one = 1.0d0 contains @@ -195,13 +195,14 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl integer, intent(out) :: errflg ! local variables - real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) + real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) integer :: i, k real(kind=kind_phys) :: tem1, tem2, tem, hocp logical, dimension(im) :: invrsn real(kind=kind_phys), dimension(im) :: tx1, tx2 - real(kind=kind_phys), parameter :: qmin = 1.0d-10, epsln=1.0d-10 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys ! Initialize CCPP error handling variables errmsg = '' @@ -218,7 +219,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl 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.0_kind_phys ) then suntim(i) = suntim(i) + dtf endif endif @@ -295,9 +296,9 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl do i=1, im invrsn(i) = .false. - tx1(i) = 0.0 - tx2(i) = 10.0 - ctei_r(i) = 10.0 + tx1(i) = zero + tx2(i) = 10.0_kind_phys + ctei_r(i) = 10.0_kind_phys enddo if ((((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) .and. mstrat) & @@ -305,13 +306,13 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ctei_rml(:) = ctei_rm(1)*work1(:) + ctei_rm(2)*work2(:) do k=1,levs/2 do i=1,im - if (prsi(i,1)-prsi(i,k+1) < 0.35*prsi(i,1) & + if (prsi(i,1)-prsi(i,k+1) < 0.35_kind_phys*prsi(i,1) & .and. (.not. invrsn(i))) then tem = (tgrs(i,k+1) - tgrs(i,k)) & / (prsl(i,k) - prsl(i,k+1)) - if (((tem > 0.00010) .and. (tx1(i) < 0.0)) .or. & - ((tem-abs(tx1(i)) > 0.0) .and. (tx2(i) < 0.0))) then + if (((tem > 0.0001_kind_phys) .and. (tx1(i) < zero)) .or. & + ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then invrsn(i) = .true. if (qgrs_water_vapor(i,k) > qgrs_water_vapor(i,k+1)) then @@ -321,10 +322,10 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k) ! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI - ctei_r(i) = (1.0/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & + ctei_r(i) = (one/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & + qgrs_cloud_water(i,k+1)-qgrs_cloud_water(i,k)) else - ctei_r(i) = 10 + ctei_r(i) = 10.0_kind_phys endif if ( ctei_rml(i) > ctei_r(i) ) then @@ -505,8 +506,9 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & !real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & ! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 ! in the following inverse of slope_mg and slope_upmg are specified - real(kind=kind_phys),parameter :: slope_mg = 50.0_kind_phys, & - slope_upmg = 25.0_kind_phys + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: slope_mg = 50.0_kind_phys, & + slope_upmg = 25.0_kind_phys ! Initialize CCPP error handling variables errmsg = '' @@ -558,10 +560,10 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & endif ! end if_ras or cfscnv or samf if (ntcw > 0) then - if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5) then ! compute rhc for GMAO macro physics cloud pdf + if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5_kind_phys) then ! compute rhc for GMAO macro physics cloud pdf do i=1,im - tx1(i) = 1.0 / prsi(i,1) - tx2(i) = 1.0 - rhcmax*work1(i)-rhcbot*work2(i) + tx1(i) = one / prsi(i,1) + tx2(i) = one - rhcmax*work1(i)-rhcbot*work2(i) kk = min(kinver(i), max(2,kpbl(i))) tx3(i) = prsi(i,kk)*tx1(i) @@ -570,18 +572,18 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & do k = 1, levs do i = 1, im tem = prsl(i,k) * tx1(i) - tem1 = min(max((tem-tx3(i))*slope_mg, -20.0), 20.0) + tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) ! Using rhcpbl and rhctop from the namelist instead of 0.3 and 0.2 ! and rhcbot represents pbl top critical relative humidity - tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0), 20.0) ! Anning + tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) ! Anning if (islmsk(i) > 0) then - tem1 = 1.0 / (1.0+exp(tem1+tem1)) + tem1 = one / (one+exp(tem1+tem1)) else - tem1 = 2.0 / (1.0+exp(tem1+tem1)) + tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) endif - tem2 = 1.0 / (1.0+exp(tem2)) + tem2 = one / (one+exp(tem2)) - rhc(i,k) = min(rhcmax, max(0.7, 1.0-tx2(i)*tem1*tem2)) + rhc(i,k) = min(rhcmax, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) enddo enddo else @@ -589,12 +591,12 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & do i=1,im kk = max(10,kpbl(i)) if (k < kk) then - tem = rhcbot - (rhcbot-rhcpbl) * (1.0-prslk(i,k)) / (1.0-prslk(i,kk)) + tem = rhcbot - (rhcbot-rhcpbl) * (one-prslk(i,k)) / (one-prslk(i,kk)) else tem = rhcpbl - (rhcpbl-rhctop) * (prslk(i,kk)-prslk(i,k)) / prslk(i,kk) endif tem = rhcmax * work1(i) + tem * work2(i) - rhc(i,k) = max(0.0, min(1.0,tem)) + rhc(i,k) = max(zero, min(one,tem)) enddo enddo endif @@ -641,7 +643,7 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & ! prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) ! enddo !*GF - rhc(:,:) = 1.0 + rhc(:,:) = one endif ! end if_ntcw end subroutine GFS_suite_interstitial_3_run @@ -688,6 +690,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to ! dqdti may not be allocated real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -745,16 +748,16 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to do k=1,levs do i=1,im gq0(i,k,ntlnc) = gq0(i,k,ntlnc) & - + max(0.0, (clw(i,k,2)-save_qc(i,k))) / liqm + + max(zero, (clw(i,k,2)-save_qc(i,k))) / liqm gq0(i,k,ntinc) = gq0(i,k,ntinc) & - + max(0.0, (clw(i,k,1)-save_qi(i,k))) / icem + + max(zero, (clw(i,k,1)-save_qi(i,k))) / icem enddo enddo else do k=1,levs do i=1,im gq0(i,k,ntinc) = gq0(i,k,ntinc) & - + max(0.0, (clw(i,k,1)-save_qi(i,k))) / icem + + max(zero, (clw(i,k,1)-save_qi(i,k))) / icem enddo enddo endif @@ -779,7 +782,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to if (cplchm) then do k=1,levs do i=1,im - dqdti(i,k) = dqdti(i,k) * (1.0 / dtf) + dqdti(i,k) = dqdti(i,k) * (one / dtf) enddo enddo endif diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index c98650b99..e12543328 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -11,7 +11,7 @@ module GFS_surface_composites_pre public GFS_surface_composites_pre_init, GFS_surface_composites_pre_finalize, GFS_surface_composites_pre_run - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0, epsln = 1.0d-10 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys contains @@ -158,7 +158,7 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl ! snowd_ocn(i) = snowd(i) weasd_ocn(i) = zero snowd_ocn(i) = zero - semis_ocn(i) = 0.984d0 + semis_ocn(i) = 0.984_kind_phys endif if (dry(i)) then ! Land uustar_lnd(i) = uustar(i) @@ -178,7 +178,7 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl snowd_ice(i) = snowd(i) ep1d_ice(i) = zero gflx_ice(i) = zero - semis_ice(i) = 0.95d0 + semis_ice(i) = 0.95_kind_phys endif enddo @@ -278,7 +278,7 @@ module GFS_surface_composites_post public GFS_surface_composites_post_init, GFS_surface_composites_post_finalize, GFS_surface_composites_post_run - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys contains @@ -357,7 +357,7 @@ subroutine GFS_surface_composites_post_run ( uustar(i) = txl*uustar_lnd(i) + txi*uustar_ice(i) + txo*uustar_ocn(i) fm10(i) = txl*fm10_lnd(i) + txi*fm10_ice(i) + txo*fm10_ocn(i) fh2(i) = txl*fh2_lnd(i) + txi*fh2_ice(i) + txo*fh2_ocn(i) - !tsurf(i) = txl*tsurf_lnd(i) + txi*tice(i) + txo*tsurf_ocn(i) + !tsurf(i) = txl*tsurf_lnd(i) + txi*tice(i) + txo*tsurf_ocn(i) !tsurf(i) = txl*tsurf_lnd(i) + txi*tsurf_ice(i) + txo*tsurf_ocn(i) ! not used again! Moorthi cmm(i) = txl*cmm_lnd(i) + txi*cmm_ice(i) + txo*cmm_ocn(i) chh(i) = txl*chh_lnd(i) + txi*chh_ice(i) + txo*chh_ocn(i) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 9cdf14d85..116b3e29f 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -11,8 +11,7 @@ module GFS_surface_generic_pre public GFS_surface_generic_pre_init, GFS_surface_generic_pre_finalize, GFS_surface_generic_pre_run - real(kind=kind_phys), parameter :: one = 1.0d0 - real(kind=kind_phys), parameter :: zero = 0.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys contains @@ -103,24 +102,24 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! Set initial quantities for stochastic physics deltas if (do_sppt) then - dtdtr = 0.0 + dtdtr = zero endif ! Scale random patterns for surface perturbations with perturbation size ! Turn vegetation fraction pattern into percentile pattern if (do_sfcperts) then - if (pertz0(1) > 0.) then + if (pertz0(1) > zero) then z01d(:) = pertz0(1) * sfc_wts(:,1) ! if (me == 0) print*,'sfc_wts(:,1) min and max',minval(sfc_wts(:,1)),maxval(sfc_wts(:,1)) ! if (me == 0) print*,'z01d min and max ',minval(z01d),maxval(z01d) endif - if (pertzt(1) > 0.) then + if (pertzt(1) > zero) then zt1d(:) = pertzt(1) * sfc_wts(:,2) endif - if (pertshc(1) > 0.) then + if (pertshc(1) > zero) then bexp1d(:) = pertshc(1) * sfc_wts(:,3) endif - if (pertlai(1) > 0.) then + if (pertlai(1) > zero) then xlai1d(:) = pertlai(1) * sfc_wts(:,4) endif ! --- do the albedo percentile calculation in GFS_radiation_driver instead --- ! @@ -130,7 +129,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! alb1d(i) = cdfz ! enddo ! endif - if (pertvegf(1) > 0.) then + if (pertvegf(1) > zero) then do i=1,im call cdfnor(sfc_wts(i,6),cdfz) vegf1d(i) = cdfz @@ -141,7 +140,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! End of stochastic physics / surface perturbation do i=1,im - sigmaf(i) = max(vfrac(i),0.01 ) + sigmaf(i) = max(vfrac(i), 0.01_kind_phys) if (islmsk(i) == 2) then if (isot == 1) then soiltyp(i) = 16 @@ -155,9 +154,9 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, endif slopetyp(i) = 9 else - soiltyp(i) = int( stype(i)+0.5 ) - vegtype(i) = int( vtype(i)+0.5 ) - slopetyp(i) = int( slope(i)+0.5 ) !! clu: slope -> slopetyp + soiltyp(i) = int( stype(i)+0.5_kind_phys ) + vegtype(i) = int( vtype(i)+0.5_kind_phys ) + slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp if (soiltyp(i) < 1) soiltyp(i) = 14 if (vegtype(i) < 1) vegtype(i) = 17 if (slopetyp(i) < 1) slopetyp(i) = 1 @@ -171,7 +170,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, smcref2(i) = zero wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - + max(zero, min(cnvwind(i), 30.0)), one) + + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) !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) @@ -201,7 +200,7 @@ module GFS_surface_generic_post public GFS_surface_generic_post_init, GFS_surface_generic_post_finalize, GFS_surface_generic_post_run - real(kind=kind_phys), parameter :: zero = 0.0, one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys contains @@ -246,7 +245,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - real(kind=kind_phys), parameter :: albdf = 0.06d0 + real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys integer :: i real(kind=kind_phys) :: xcosz_loc, ocalnirdf_cpl, ocalnirbm_cpl, ocalvisdf_cpl, ocalvisbm_cpl @@ -305,11 +304,11 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt if (wet(i)) then ! some open water ! --- compute open water albedo xcosz_loc = max( zero, min( one, xcosz(i) )) - ocalnirdf_cpl = 0.06d0 - ocalnirbm_cpl = max(albdf, 0.026d0/(xcosz_loc**1.7d0+0.065d0) & - & + 0.15d0 * (xcosz_loc-0.1d0) * (xcosz_loc-0.5d0) & + ocalnirdf_cpl = 0.06_kind_phys + ocalnirbm_cpl = 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 = 0.06d0 + ocalvisdf_cpl = 0.06_kind_phys ocalvisbm_cpl = ocalnirbm_cpl nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) @@ -323,7 +322,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) endif nswsfci_cpl(i) = nnirbmi_cpl(i) + nnirdfi_cpl(i) & - + nvisbmi_cpl(i) + nvisdfi_cpl(i) + + nvisbmi_cpl(i) + nvisdfi_cpl(i) nswsfc_cpl(i) = nswsfc_cpl(i) + nswsfci_cpl(i)*dtf nnirbm_cpl(i) = nnirbm_cpl(i) + nnirbmi_cpl(i)*dtf nnirdf_cpl(i) = nnirdf_cpl(i) + nnirdfi_cpl(i)*dtf diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 521070af7..ba7963e7d 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -175,12 +175,13 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & !------------------------------------ ! input ! real, parameter :: r_air = 3.47d-3 - 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.0d-14, rainmin = 1.0d-13, & - & fourb3=4.0d0/3.0d0, RL_cub=1.0d-15, nmin=1.0d0 + real, parameter :: one=1.0_kind_phys, oneb3=one/3.0_kind_phys, onebcp=one/cp, & + zero=0.0_kind_phys, half=0.5_kind_phys, onebg=one/grav, & + & kapa=rgas*onebcp, cpbg=cp/grav, & + & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp, & + & qsmall=1.0e-14_kind_phys, rainmin = 1.0e-13_kind_phys, & + & fourb3=4.0_kind_phys/3.0_kind_phys, RL_cub=1.0e-15_kind_phys, & + & nmin=1.0_kind_phys integer, parameter :: ncolmicro = 1 integer,intent(in) :: im, ix,lm, kdt, fprcp, pdfflag, iccn @@ -354,27 +355,27 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! real (kind=kind_phys), parameter :: disp_liu=2., ui_scale=1.0 & ! &, dcrit=20.0d-6 & - real (kind=kind_phys), parameter :: disp_liu=1.0d0 & - &, ui_scale=1.0d0 & - &, dcrit=1.0d-6 & + real (kind=kind_phys), parameter :: disp_liu=1.0_kind_phys & + &, ui_scale=1.0_kind_phys & + &, dcrit=1.0e-6_kind_phys & ! &, ts_autice=1800.0 & ! &, ts_autice=3600.0 & !time scale - &, ninstr8 = 0.1d6 & - &, ncnstr8 = 100.0d6 + &, ninstr8 = 0.1e6_kind_phys & + &, ncnstr8 = 100.0e6_kind_phys 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.05d0 ! normalized pressure at sedimentation start + integer, dimension(1) :: lev_sed_strt ! sedimentation start level + real(kind=kind_phys), parameter :: sig_sed_strt=0.05_kind_phys ! 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.0d0, fsoot_drop=0.1d0 & - &, sigma_nuc_r8=0.28d0,SCLMFDFR=0.03d0 + real(kind=kind_phys), parameter ::fdust_drop=1.0_kind_phys, fsoot_drop=0.1_kind_phys & + &, sigma_nuc_r8=0.28_kind_phys,SCLMFDFR=0.03_kind_phys ! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1 type (AerProps), dimension (IM,LM) :: AeroProps @@ -440,7 +441,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & 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),zero) - PLO(i,k) = prsl_i(i,ll)*0.01d0 + PLO(i,k) = prsl_i(i,ll)*0.01_kind_phys 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) @@ -455,7 +456,7 @@ subroutine m_micro_run( 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.01_kind_phys ! interface pressure in hPa zet(i,k+1) = phii(i,ll) * onebg END DO END DO @@ -500,7 +501,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & 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),zero) - PLO(i,k) = prsl_i(i,k)*0.01d0 + PLO(i,k) = prsl_i(i,k)*0.01_kind_phys 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) @@ -514,7 +515,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & END DO DO K=0, LM DO I = 1,IM - PLE(i,k) = prsi_i(i,k) * 0.01d0 ! interface pressure in hPa + PLE(i,k) = prsi_i(i,k) * 0.01_kind_phys ! interface pressure in hPa zet(i,k+1) = phii(i,k) * onebg END DO END DO @@ -553,17 +554,17 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if (rnw(i,k) <= qc_min(1)) then 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) + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kind_phys), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) endif enddo @@ -577,8 +578,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & DO I=1, IM DO K = LM-2, 10, -1 - If ((CNV_DQLDT(I,K) <= 1.0d-9) .and. & - & (CNV_DQLDT(I,K+1) > 1.0d-9)) then + If ((CNV_DQLDT(I,K) <= 1.0e-9_kind_phys) .and. & + & (CNV_DQLDT(I,K+1) > 1.0e-9_kind_phys)) then KCT(I) = K+1 exit end if @@ -658,7 +659,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do l=lm-1,1,-1 do i=1,im 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 + kh(i,l) = 3.55e-7_kind_phys*tx1**2.5_kind_phys*(rgas*0.01_kind_phys) / ple(i,l) !kh molecule diff only needing refinement enddo end do do i=1,im @@ -667,8 +668,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & enddo 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)*0.4d0) ) + blk_l(i,l) = one / ( one/max(0.15_kind_phys*ZPBL(i),0.4_kind_phys*zlo(i,lm-1))& + & + one/(zlo(i,l)*0.4_kind_phys) ) SC_ICE(i,l) = one NCPL(i,l) = MAX( NCPL(i,l), zero) @@ -687,8 +688,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do l=1,lm - rhdfdar8(l) = 1.d-8 - rhu00r8(l) = 0.95d0 + rhdfdar8(l) = 1.e-8_kind_phys + rhu00r8(l) = 0.95_kind_phys ttendr8(l) = zero qtendr8(l) = zero @@ -733,8 +734,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if ( iccn == 2) then AERMASSMIX(:,:,1:ntrcaer) = aerfld_i(:,:,1:ntrcaer) else - AERMASSMIX(:,:,1:5) = 1.0d-6 - AERMASSMIX(:,:,6:15) = 2.0d-14 + AERMASSMIX(:,:,1:5) = 1.0e-6_kind_phys + AERMASSMIX(:,:,6:15) = 2.0e-14_kind_phys end if !> - Call aerconversion1() call AerConversion1 (AERMASSMIX, AeroProps) @@ -753,23 +754,23 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & kcldtopcvn = KCT(I) tausurf_gw = min(half*SQRT(TAUOROX(I)*TAUOROX(I) & - & + TAUOROY(I)*TAUOROY(I)), 10.0d0) + & + TAUOROY(I)*TAUOROY(I)), 10.0_kind_phys) do k=1,lm uwind_gw(k) = min(half*SQRT( U1(I,k)*U1(I,k) & - & + V1(I,k)*V1(I,k)), 50.0d0) + & + V1(I,k)*V1(I,k)), 50.0_kind_phys) ! 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.0d0*PLO(I,k) + pm_gw(k) = 100.0_kind_phys*PLO(I,k) tm_gw(k) = TEMP(I,k) nm_gw(k) = zero rho_gw(k) = pm_gw(k) /(RGAS*tm_gw(k)) ter8(k) = TEMP(I,k) - plevr8(k) = 100.0d0*PLO(I,k) + plevr8(k) = 100.0_kind_phys*PLO(I,k) ndropr8(k) = NCPL(I,k) qir8(k) = QILS(I,k) + QICN(I,k) qcr8(k) = QLLS(I,k) + QLCN(I,k) @@ -780,27 +781,27 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & npre8(k) = zero - if (RAD_CF(I,k) > 0.01d0 .and. qir8(k) > zero) then + if (RAD_CF(I,k) > 0.01_kind_phys .and. qir8(k) > zero) then npre8(k) = NPRE_FRAC*NCPI(I,k) else npre8(k) = zero endif omegr8(k) = OMEGA(I,k) - lc_turb(k) = max(blk_l(I,k), 50.0d0) + lc_turb(k) = max(blk_l(I,k), 50.0_kind_phys) ! rad_cooling(k) = RADheat(I,k) if (npre8(k) > zero .and. qir8(k) > zero) then - dpre8(k) = ( qir8(k)/(6.0d0*npre8(k)*900.0d0*PI))**(one/3.0d0) + dpre8(k) = ( qir8(k)/(6.0_kind_phys*npre8(k)*900.0_kind_phys*PI))**(one/3.0_kind_phys) else - dpre8(k) = 1.0d-9 + dpre8(k) = 1.0e-9_kind_phys 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.0d0*PLE(I,k) + pi_gw(k) = 100.0_kind_phys*PLE(I,k) rhoi_gw(k) = zero ni_gw(k) = zero ti_gw(k) = zero @@ -816,13 +817,13 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & & ti_gw, nm_gw, q1(i,:)) do k=1,lm - nm_gw(k) = max(nm_gw(k), 0.005d0) + nm_gw(k) = max(nm_gw(k), 0.005_kind_phys) h_gw(k) = k_gw*rho_gw(k)*uwind_gw(k)*nm_gw(k) if (h_gw(K) > zero) then - h_gw(K) = sqrt(2.0d0*tausurf_gw/h_gw(K)) + h_gw(K) = sqrt(2.0_kind_phys*tausurf_gw/h_gw(K)) end if - wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133d0 + wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133_kind_phys wparc_cgw(k) = zero end do @@ -839,14 +840,14 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do k=1,kcldtopcvn c2_gw = (nm_gw(k) + Nct) / Nct - wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56d0* & - & 1.806d0*c2_gw*c2_gw)*Wct*0.133d0 + wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56_kind_phys* & + & 1.806_kind_phys*c2_gw*c2_gw)*Wct*0.133_kind_phys enddo end if do k=1,lm - dummyW(k) = 0.133d0*k_gw*uwind_gw(k)/nm_gw(k) + dummyW(k) = 0.133_kind_phys*k_gw*uwind_gw(k)/nm_gw(k) enddo do K=1, LM-5, 1 @@ -866,17 +867,17 @@ subroutine m_micro_run( 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.0d0 + dummyW(k) = 10.0_kind_phys enddo - if (FRLAND(I) < 0.1d0 .and. ZPBL(I) < 800.0d0 .and. & - & TEMP(I,LM) < 298.0d0 .and. TEMP(I,LM) > 274.0d0 ) then + if (FRLAND(I) < 0.1_kind_phys .and. ZPBL(I) < 800.0_kind_phys .and. & + & TEMP(I,LM) < 298.0_kind_phys .and. TEMP(I,LM) > 274.0_kind_phys) then do K = 1, LM - dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01d0,10.0d0),-10.0d0) + dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01_kind_phys, 10.0_kind_phys),-10.0_kind_phys) dummyW(k) = one / (one+exp(dummyW(k))) enddo maxkh = max(maxval(KH(I,kbmin:LM-1)*nm_gw(kbmin:LM-1)/ & - & 0.17d0), 0.3d0) + & 0.17_kind_phys), 0.3_kind_phys) do K = 1, LM wparc_turb(k) = (one-dummyW(k))*wparc_turb(k) & & + dummyW(k)*maxkh @@ -884,7 +885,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & end if - wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2d0) + wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2_kind_phys) @@ -902,11 +903,11 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do K = 1, LM - if (plevr8(K) > 70.0d0) then + if (plevr8(K) > 70.0_kind_phys) then - ccn_diag(1) = 0.001d0 - ccn_diag(2) = 0.004d0 - ccn_diag(3) = 0.01d0 + ccn_diag(1) = 0.001_kind_phys + ccn_diag(2) = 0.004_kind_phys + ccn_diag(3) = 0.01_kind_phys if (K > 2 .and. K <= LM-2) then tauxr8 = (ter8(K-1) + ter8(K+1) + ter8(K)) * oneb3 @@ -957,7 +958,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & swparc(K) = zero smaxicer8(K) = zero nheticer8(K) = zero - sc_icer8(K) = 2.0d0 + sc_icer8(K) = 2.0_kind_phys ! sc_icer8(K) = 1.0d0 naair8(K) = zero npccninr8(K) = zero @@ -974,9 +975,9 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! SMAXL(I,k) = smaxliq(k) * 100.0 ! SMAXI(I,k) = smaxicer8(k) * 100.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) + NHET_NUC(I,k) = nheticer8(k) * 1.0e-6_kind_phys + NLIM_NUC(I,k) = nlimicer8(k) * 1.0e-6_kind_phys + SC_ICE(I,k) = min(max(sc_icer8(k),one),2.0_kind_phys) ! 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) @@ -986,13 +987,13 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if (iccn == 0) then 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.5d0) + SC_ICE(i,k) = max(SC_ICE(I,k), 1.5_kind_phys) 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.5d0) + tx1 = max(SC_ICE(I,k), 1.5_kind_phys) SC_ICE(i,k) = ((tice-temp(i,k))*tx1 + (temp(i,k)-t_ice_all)*rhc(i,k)) & * t_ice_denom endif @@ -1003,12 +1004,12 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & endif 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 + NHET_DEP(I,k) = nhet_depr8(k) * 1.0e-6_kind_phys + NHET_DHF(I,k) = nhet_dhfr8(k) * 1.0e-6_kind_phys + DUST_IMM(I,k) = max(dust_immr8(k), zero)*1.0e-6_kind_phys + DUST_DEP(I,k) = max(dust_depr8(k), zero)*1.0e-6_kind_phys + DUST_DHF(I,k) = max(dust_dhfr8(k), zero)*1.0e-6_kind_phys + WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8_kind_phys 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) @@ -1121,7 +1122,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do k=1,lm do i=1,im - if (CNV_MFD(i,k) > 1.0d-6) then + if (CNV_MFD(i,k) > 1.0e-6_kind_phys) 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 @@ -1230,7 +1231,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do l=1,10 do k=1,lm naconr8(k,l) = zero - rndstr8(k,l) = 2.0d-7 + rndstr8(k,l) = 2.0e-7_kind_phys enddo enddo do k=1,lm @@ -1241,7 +1242,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) tx1 = MIN(CLLS(I,k) + CLCN(I,k), one) if (tx1 > zero) then - cldfr8(k) = min(max(tx1, 0.00001d0), one) + cldfr8(k) = min(max(tx1, 0.00001_kind_phys), one) else cldfr8(k) = zero endif @@ -1277,7 +1278,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & naair8(k) = INC_NUC(I,k) npccninr8(k) = CDNC_NUC(I,k) - if (cldfr8(k) >= 0.001d0) then + if (cldfr8(k) >= 0.001_kind_phys) then nimmr8(k) = min(DNHET_IMM(I,k),ncr8(k)/(cldfr8(k)*DT_MOIST)) else nimmr8(k) = zero @@ -1305,11 +1306,11 @@ subroutine m_micro_run( 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.0d0 + pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0_kind_phys rpdelr8(k) = one / pdelr8(k) - plevr8(k) = 100.0d0 * PLO(I,k) + plevr8(k) = 100.0_kind_phys * PLO(I,k) zmr8(k) = ZLO(I,k) - ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.0d-10) + ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.0e-10_kind_phys) omegr8(k) = WSUB(I,k) ! alphar8(k) = max(alpht_x(i,k)/maxval(alpht_x(i,:))*8.,0.5) ! alphar8(k) = qcvar2 @@ -1317,7 +1318,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & END DO do k=1,lm+1 - pintr8(k) = PLE(I,k-1) * 100.0d0 + pintr8(k) = PLE(I,k-1) * 100.0_kind_phys kkvhr8(k) = KH(I,k-1) END DO @@ -1402,8 +1403,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! if (lprint) write(0,*)' prectr8=',prectr8(1), & ! & ' precir8=',precir8(1) - LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0d0*precir8(1), zero) + LS_PRC2(I) = max(1000.0_kind_phys*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_kind_phys*precir8(1), zero) do k=1,lm @@ -1421,10 +1422,10 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & NCPR(I,k) = nrr8(k) NCPS(I,k) = nsr8(k) - 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.5d0*1.0d6, 150.0d0) - CLDREFFS(I,k) = max(0.192d0*dsoutr8(k)*0.5d0*1.0d6, 250.0d0) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_kind_phys), 150.0_kind_phys) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_kind_phys), 150.0_kind_phys) + CLDREFFR(I,k) = max(droutr8(k)*0.5_kind_phys*1.0e6_kind_phys, 150.0_kind_phys) + CLDREFFS(I,k) = max(0.192_kind_phys*dsoutr8(k)*0.5_kind_phys*1.0e6_kind_phys, 250.0_kind_phys) enddo ! K loop @@ -1506,8 +1507,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, & & lev_sed_strt) ! - LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0d0*precir8(1), zero) + LS_PRC2(I) = max(1000.0_kind_phys*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_kind_phys*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 @@ -1521,10 +1522,10 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & 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.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) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_kind_phys), 150.0_kind_phys) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_kind_phys), 150.0_kind_phys) + CLDREFFR(I,k) = max(reff_rain(k), 150.0_kind_phys) + CLDREFFS(I,k) = max(reff_snow(k), 250.0_kind_phys) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1535,10 +1536,10 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & LS_PRC2(I) = zero LS_SNR(I) = zero do k=1,lm - CLDREFFL(I,k) = 10.0d0 - CLDREFFI(I,k) = 50.0d0 - CLDREFFR(I,k) = 1000.0d0 - CLDREFFS(I,k) = 250.0d0 + CLDREFFL(I,k) = 10.0_kind_phys + CLDREFFI(I,k) = 50.0_kind_phys + CLDREFFR(I,k) = 1000.0_kind_phys + CLDREFFS(I,k) = 250.0_kind_phys enddo ! K loop endif ! @@ -1643,8 +1644,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, & & lev_sed_strt) - LS_PRC2(I) = max(1000.0d0*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0d0*precir8(1), zero) + LS_PRC2(I) = max(1000.0_kind_phys*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_kind_phys*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 @@ -1660,11 +1661,11 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & 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) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_kind_phys), 150.0_kind_phys) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_kind_phys), 150.0_kind_phys) + CLDREFFR(I,k) = max(reff_rain(k),150.0_kind_phys) + CLDREFFS(I,k) = max(reff_snow(k),250.0_kind_phys) + CLDREFFG(I,k) = max(reff_grau(k),250.0_kind_phys) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1675,11 +1676,11 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & LS_PRC2(I) = zero LS_SNR(I) = zero do k=1,lm - 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 + CLDREFFL(I,k) = 10.0_kind_phys + CLDREFFI(I,k) = 50.0_kind_phys + CLDREFFR(I,k) = 1000.0_kind_phys + CLDREFFS(I,k) = 250.0_kind_phys + CLDREFFG(I,k) = 250.0_kind_phys enddo ! K loop endif endif @@ -1707,17 +1708,17 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if (rnw(i,k) <= qc_min(1)) then 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) + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kind_phys), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) endif enddo enddo @@ -1747,17 +1748,17 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if (rnw(i,k) <= qc_min(1)) then 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) + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kind_phys), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0d0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) endif enddo enddo @@ -1849,7 +1850,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & DO I = 1,IM tx1 = LS_PRC2(i) + LS_SNR(i) - rn_o(i) = tx1 * dt_i * 0.001d0 + rn_o(i) = tx1 * dt_i * 0.001_kind_phys if (rn_o(i) < rainmin) then sr_o(i) = zero diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index 6164cf544..636293b86 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -324,7 +324,7 @@ subroutine micro_mg_init( & !----------------------------------------------------------------------- - dcs = micro_mg_dcs * 1.0e-6 + dcs = micro_mg_dcs * 1.0e-6_r8 ts_au_min = ts_auto(1) ts_au = ts_auto(2) qcvar = mg_qcvar @@ -613,7 +613,6 @@ subroutine micro_mg_tend ( & integer, intent(in) :: iccn !< flag for IN and CCN forcing for Morrison-Gettelman microphysics - ! used for scavenging ! Inputs for aerosol activation real(r8), intent(inout) :: naai(mgncol,nlev) !< ice nucleation number (from microp_aero_ts) (1/kg) @@ -1091,7 +1090,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 @@ -3194,9 +3193,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 @@ -3798,9 +3797,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 @@ -4049,7 +4048,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/physics/moninshoc.f b/physics/moninshoc.f index 5bdf0ceef..4afe19dec 100644 --- a/physics/moninshoc.f +++ b/physics/moninshoc.f @@ -71,6 +71,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! ! locals ! + integer, parameter :: r8 = kind_phys integer i,is,k,kk,km1,kmpbl,kp1, ntloc ! logical pblflg(im), sfcflg(im), flg(im) @@ -91,15 +92,16 @@ subroutine moninshoc_run (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 :: one=1.0d0, zero=0.0d0 - &, 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 - &, dkmin=zero, dkmax=1000.0d0 -! &, dkmin=zero, dkmax=1000., xkzminv=0.3 - &, prmin=0.25d0, prmax=4.0d0, vk=0.4, cfac=6.5 + real(kind=kind_phys), parameter :: one=1.0_r8, zero=0.0_r8 + &, zolcr=0.2_r8, + & zolcru=-0.5_r8, rimin=-100.0_r8, sfcfrac=0.1_r8, + & crbcon=0.25_r8, crbmin=0.15_r8, crbmax=0.35_r8, + & qmin=1.0e-8_r8, zfmin=1.0d-8, qlmin=1.0e-12_r8, + & aphi5=5.0_r8, aphi16=16.0_r8, f0=1.0e-4_r8 + &, dkmin=zero, dkmax=1000.0_r8 +! &, dkmin=zero, dkmax=1000., xkzminv=0.3 + &, prmin=0.25_r8, prmax=4.0_r8, vk=0.4_r8, + & cfac=6.5_r8 real(kind=kind_phys) :: gravi, cont, conq, conw, gocp gravi = one/grav @@ -155,7 +157,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, if (k <= kinver(i)) then ! vertical background diffusivity for heat and momentum tem1 = one - prsi(i,k+1) * tx1(i) - tem1 = min(one, exp(-tem1 * tem1 * 10.0d0)) + tem1 = min(one, exp(-tem1 * tem1 * 10.0_r8)) xkzo(i,k) = xkzm_h * tem1 xkzmo(i,k) = xkzm_m * tem1 endif @@ -166,9 +168,9 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! do k = 1,kmpbl do i=1,im - if(zi(i,k+1) > 250.0d0) then + if(zi(i,k+1) > 250.0_r8) then tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 > 1.0d-5) then + if(tem1 > 1.0e-5_r8) then xkzo(i,k) = min(xkzo(i,k),xkzminv) endif endif @@ -177,7 +179,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! ! do i = 1,im - z0(i) = 0.01d0 * zorl(i) + z0(i) = 0.01_r8 * zorl(i) kpbl(i) = 1 hpbl(i) = zi(i,1) pblflg(i) = .true. @@ -224,9 +226,9 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, 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.0d-7 * robn - crb(i) = max(min(0.16d0 * (tem1 ** (-0.18d0)), crbmax), - & crbmin) + tem1 = 1.0e-7_r8 * robn + crb(i) = max(min(0.16_r8 * (tem1 ** (-0.18_r8)), crbmax), + & crbmin) endif enddo do k = 1, kmpbl @@ -272,7 +274,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, if(sfcflg(i)) then ! phim(i) = (1.-aphi16*zol1)**(-1./4.) ! phih(i) = (1.-aphi16*zol1)**(-1./2.) - tem = one / max(one - aphi16*zol1, 1.0d-8) + tem = one / max(one - aphi16*zol1, 1.0e-8_r8) phih(i) = sqrt(tem) phim(i) = sqrt(phih(i)) else @@ -346,13 +348,13 @@ subroutine moninshoc_run (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.5d0*grav)*(thvx(i,kp1)-thvx(i,k))*rdz + bvf2 = (0.5_r8*grav)*(thvx(i,kp1)-thvx(i,k))*rdz & / (t1(i,k)+t1(i,kp1)) ri = max(bvf2/tem,rimin) if(ri < zero) then ! unstable regime prnum(i,kp1) = one else - prnum(i,kp1) = min(one + 2.1d0*ri, prmax) + prnum(i,kp1) = min(one + 2.1_r8*ri, prmax) endif elseif (k > 1) then prnum(i,kp1) = prnum(i,1) diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index f52b6d829..5d8e19643 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -194,16 +194,18 @@ subroutine lsm_noah_run & implicit none ! --- constant parameters: - real(kind=kind_phys), parameter :: one = 1.0d0, zero = 0.0d0 - 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 :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + real(kind=kind_phys), parameter :: rhoh2o = 1000.0_kind_phys + real(kind=kind_phys), parameter :: a2 = 17.2693882_kind_phys + real(kind=kind_phys), parameter :: a3 = 273.16_kind_phys + real(kind=kind_phys), parameter :: a4 = 35.86_kind_phys 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.0e-8_kind_phys real(kind=kind_phys), save :: zsoil_noah(4) - data zsoil_noah / -0.1d0, -0.4d0, -1.0d0, -2.0d0 / + data zsoil_noah / -0.1_kind_phys, -0.4_kind_phys, & + & -1.0_kind_phys, -2.0_kind_phys / ! --- input: integer, intent(in) :: im, km, isot, ivegsrc @@ -445,8 +447,8 @@ subroutine lsm_noah_run & ! cm - surface exchange coefficient for momentum (\f$m s^{-1}\f$) -> cmx ! z0 - surface roughness (\f$m\f$) -> zorl(\f$cm\f$) - cmc = canopy(i) * 0.001d0 ! convert from mm to m - tsea = tsurf(i) ! clu_q2m_iter + cmc = canopy(i) * 0.001_kind_phys ! convert from mm to m + tsea = tsurf(i) ! clu_q2m_iter do k = 1, km stsoil(k) = stc(i,k) @@ -454,10 +456,10 @@ subroutine lsm_noah_run & slsoil(k) = slc(i,k) enddo - snowh = snwdph(i) * 0.001d0 ! convert from mm to m - sneqv = weasd(i) * 0.001d0 ! convert from mm to m + snowh = snwdph(i) * 0.001_kind_phys ! convert from mm to m + sneqv = weasd(i) * 0.001_kind_phys ! convert from mm to m if (sneqv /= zero .and. snowh == zero) then - snowh = 10.0d0 * sneqv + snowh = 10.0_kind_phys * sneqv endif chx = ch(i) * wind(i) ! compute conductance @@ -466,7 +468,7 @@ subroutine lsm_noah_run & cmm(i) = cmx ! ---- ... outside sflx, roughness uses cm as unit - z0 = zorl(i) * 0.01d0 + z0 = zorl(i) * 0.01_kind_phys ! ---- mgehne, sfc-perts ! - Apply perturbation of soil type b parameter and leave area index. bexpp = bexppert(i) ! sfc perts, mgehne @@ -511,7 +513,7 @@ subroutine lsm_noah_run & trans(i) = ett sbsno(i) = esnow snowc(i) = sncovr - stm(i) = soilm * 1000.0d0 ! unit conversion (from m to kg m-2) + stm(i) = soilm * 1000.0_kind_phys ! unit conversion (from m to kg m-2) snohf(i) = flx1 + flx2 + flx3 smcwlt2(i) = smcwlt @@ -528,17 +530,17 @@ subroutine lsm_noah_run & wet1(i) = smsoil(1) / smcmax !Sarah Lu added 09/09/2010 (for GOCART) ! --- ... unit conversion (from m s-1 to mm s-1 and kg m-2 s-1) - runoff(i) = runoff1 * 1000.0d0 - drain (i) = runoff2 * 1000.0d0 + runoff(i) = runoff1 * 1000.0_kind_phys + drain (i) = runoff2 * 1000.0_kind_phys ! --- ... unit conversion (from m to mm) - canopy(i) = cmc * 1000.0d0 - snwdph(i) = snowh * 1000.0d0 - weasd(i) = sneqv * 1000.0d0 + canopy(i) = cmc * 1000.0_kind_phys + snwdph(i) = snowh * 1000.0_kind_phys + weasd(i) = sneqv * 1000.0_kind_phys sncovr1(i) = sncovr ! ---- ... outside sflx, roughness uses cm as unit (update after snow's ! effect) - zorl(i) = z0*100.0d0 + zorl(i) = z0*100.0_kind_phys !> - Do not return the following output fields to parent model: !!\n ec - canopy water evaporation (m s-1) diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index ba0aec030..d937ddf49 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -91,8 +91,8 @@ subroutine sfc_ocean_run & implicit none ! --- constant parameters: - real (kind=kind_phys), parameter :: one = 1.0d0, zero = 0.0d0 & - &, qmin = 1.0d-8 + real (kind=kind_phys), parameter :: one = 1.0_kind_phys, zero = 0.0_kind_phys & + &, qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im real (kind=kind_phys), intent(in) :: rd, eps, epsm1, rvrdm1 diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index db483ee75..8648e631b 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -138,15 +138,15 @@ subroutine sfc_sice_run & implicit none ! ! - Define constant parameters - integer, parameter :: kmi = 2 !< 2-layer of ice - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 - 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 + integer, parameter :: kmi = 2 !< 2-layer of ice + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + 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 @@ -232,7 +232,7 @@ subroutine sfc_sice_run & if (flag(i)) then if (srflag(i) > zero) then ep(i) = ep(i)*(one-srflag(i)) - weasd(i) = weasd(i) + 1.0d3*tprcp(i)*srflag(i) + weasd(i) = weasd(i) + 1000.0_kind_phys*tprcp(i)*srflag(i) tprcp(i) = tprcp(i)*(one-srflag(i)) endif endif @@ -289,7 +289,7 @@ subroutine sfc_sice_run & !> - Convert snow depth in water equivalent 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 @@ -310,7 +310,8 @@ subroutine sfc_sice_run & ! 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)) !> - Calculate net solar incoming at top \a sneti. sneti(i) = (sfcnsw(i) - ffw(i)*snetw(i)) / fice(i) @@ -327,7 +328,7 @@ subroutine sfc_sice_run & & + rch(i)*(tice(i) - theta1(i)) #endif !> - Calculate heat flux derivative at surface \a hfd. - 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) t12 = tgice * tgice @@ -340,14 +341,14 @@ subroutine sfc_sice_run & !> - Assigin heat flux from ocean \a focn and snowfall rate as constants, which !! should be from ocean model and other physics. - 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 !> - Initialize snow depth \a snowd. 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) @@ -417,7 +418,7 @@ subroutine sfc_sice_run & ! --- ... 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) @@ -520,28 +521,28 @@ 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, one = 1.0_kind_phys ! --- inputs: integer, intent(in) :: im, kmi, ipr @@ -631,7 +632,7 @@ subroutine ice3lay !> - Calculate the new upper ice temperature following \a eq.(21) !! in Winton (2000) \cite winton_2000. - stsice(i,1) = -(sqrt(b1*b1 - 4.0d0*a1*c1) + b1)/(a1+a1) + stsice(i,1) = -(sqrt(b1*b1-4.0_kind_phys*a1*c1) + b1)/(a1+a1) tice(i) = (k12*stsice(i,1) - ai) / (k12 + bi) !> - If the surface temperature is greater than the freezing temperature @@ -644,7 +645,8 @@ subroutine ice3lay 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-4.0_kind_phys*a1*c1) + b1) & + & / (a1+a1) tice(i) = tsf tmelt = (k12*(stsice(i,1)-tsf) - (ai+bi*tsf)) * delt else @@ -664,8 +666,8 @@ subroutine ice3lay !> - Calculation of ice and snow mass changes. - h1 = 0.5d0 * hice(i) - h2 = 0.5d0 * hice(i) + h1 = 0.5_kind_phys * hice(i) + h2 = 0.5_kind_phys * hice(i) !> - Calculate the top layer thickness. @@ -697,7 +699,7 @@ subroutine ice3lay hice(i) = h1 + h2 if (hice(i) > zero) then - if (h1 > 0.5d0*hice(i)) then + if (h1 > 0.5_kind_phys*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) @@ -711,7 +713,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 + & - 4.0_kind_phys*tfi*li/ci)) * 0.5_kind_phys endif k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) From e19953d0da2ccd4b65bc4ac68a2cc09807805474 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 22 Apr 2020 17:45:31 +0000 Subject: [PATCH 08/30] adding _kind_phys to constants in some physics routines --- physics/rascnv.F90 | 401 +++++++++++++++++++++++---------------------- 1 file changed, 201 insertions(+), 200 deletions(-) diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index 40d0ecb0d..c6601a5cb 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -10,37 +10,38 @@ module rascnv private logical :: is_initialized = .False. ! + integer, parameter :: r8 = kind_phys integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s integer, parameter :: idnmax=999 - real (kind=kind_phys), parameter :: delt_c=1800.0d0/3600.0d0 & + real (kind=kind_phys), parameter :: delt_c=1800.0_r8/3600.0_r8 & ! 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.0d0, adjts_s=0.5d0 + &, adjts_d=2.0_r8, adjts_s=0.5_r8 ! logical, parameter :: fix_ncld_hr=.true. ! - 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.0d2, 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) & - &, facmb = 0.01d0 & ! conversion factor from Pa to hPa (or mb) - &, cmb2pa = 100.0d0 ! Conversion from hPa to Pa -! - real(kind=kind_phys), parameter :: frac=0.5d0, crtmsf=0.0d0 & - &, rhfacs=0.75d0, rhfacl=0.75d0 & - &, face=5.0d0, delx=10000.0d0 & - &, ddfac=face*delx*0.001d0 & - &, max_neg_bouy=0.15d0 & -! &, max_neg_bouy=pt25d0 & - &, testmb=0.1, testmbi=one/testmb & - &, dpd=0.5d0, rknob=1.0d0, eknob=1.0d0 + real (kind=kind_phys), parameter :: ZERO=0.0_r8, HALF=0.5_r8 & + &, pt25=0.25_r8, ONE=1.0_r8 & + &, TWO=2.0_r8, FOUR=4.0_r8 & + &, twoo3=two/3.0_r8 & + &, FOUR_P2=4.0e2_r8, ONE_M10=1.0e-10_r8& + &, ONE_M6=1.0e-6_r8, ONE_M5=1.0e-5_r8 & + &, ONE_M2=1.0e-2_r8, ONE_M1=1.0e-1_r8 & + &, oneolog10=one/log(10.0_r8) & + &, facmb = 0.01_r8 & ! conversion factor from Pa to hPa (or mb) + &, cmb2pa = 100.0_r8 ! Conversion from hPa to Pa +! + real(kind=kind_phys), parameter :: frac=0.5_r8, crtmsf=0.0_r8 & + &, rhfacs=0.75_r8, rhfacl=0.75_r8 & + &, face=5.0_r8, delx=10000.0_r8& + &, ddfac=face*delx*0.001_r8 & + &, max_neg_bouy=0.15_r8 & +! &, max_neg_bouy=pt25_r8 & + &, testmb=0.1_r8, testmbi=one/testmb & + &, dpd=0.5_r8, rknob=1.0_r8, eknob=1.0_r8 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! logical, parameter :: do_aw=.true., cumfrc=.true. & @@ -52,17 +53,17 @@ module rascnv ! &, advcld=.true., advups=.false.,advtvd=.false. - real(kind=kind_phys), parameter :: TF=233.16d0, TCR=273.16d0 & - &, TCRF=one/(TCR-TF), TCL=2.0d0 + real(kind=kind_phys), parameter :: TF=233.16_r8, TCR=273.16_r8 & + &, TCRF=one/(TCR-TF), TCL=2.0_r8 ! ! For pressure gradient force in momentum mixing -! real (kind=kind_phys), parameter :: pgftop=0.80, pgfbot=0.30 & +! 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.0d0, pgfbot=0.0d0 & -! real (kind=kind_phys), parameter :: pgftop=0.55, pgfbot=0.55 & - &, pgfgrad=(pgfbot-pgftop)*0.001d0& - &, cfmax=0.1d0 + real (kind=kind_phys), parameter :: pgftop=0.0_r8, pgfbot=0.0_r8 & +! real (kind=kind_phys), parameter :: pgftop=0.55, pgfbot=0.55 & + &, pgfgrad=(pgfbot-pgftop)*0.001_r8& + &, cfmax=0.1_r8 ! ! For Tilting Angle Specification ! @@ -120,7 +121,7 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! - real(kind=kind_phys), parameter :: actp=1.7, facm=1.00 + real(kind=kind_phys), parameter :: actp=1.7_r8, facm=1.00_r8 ! real(kind=kind_phys) PH(15), A(15) ! @@ -167,7 +168,7 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & ! ! VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 ! - AFC = -(1.01097d-4*DT)*(3600.0d0/DT)**0.57777778d0 + AFC = -(1.01097e-4_r8*DT)*(3600.0_r8/DT)**0.57777778_r8 ! grav = con_g ; cp = con_cp ; alhl = con_hvap alhf = con_hfus ; rgas = con_rd @@ -179,15 +180,15 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & pi = four*atan(one) ; PIINV = one/PI ONEBG = ONE / GRAV ; GRAVCON = cmb2pa * ONEBG onebcp = one / cp ; GRAVFAC = GRAV / CMB2PA - rkap = rgas * onebcp ; deg2rad = pi/180.d0 + rkap = rgas * onebcp ; deg2rad = pi/180.0_r8 ELOCP = ALHL * onebcp ; ELFOCP = (ALHL+ALHF) * onebcp oneoalhl = one/alhl ; CMPOR = CMB2PA / RGAS - picon = half*pi*onebg ; zfac = 0.28888889d-4 * ONEBG + picon = half*pi*onebg ; zfac = 0.28888889e-4_r8 * ONEBG testmboalhl = testmb/alhl ! - rvi = one/rv ; facw=CVAP-CLIQ - faci = CVAP-CSOL ; hsub=alhl+alhf - tmix = TTP-20.0d0 ; DEN=one/(TTP-TMIX) + rvi = one/rv ; facw=CVAP-CLIQ + faci = CVAP-CSOL ; hsub=alhl+alhf + tmix = TTP-20.0_r8 ; DEN=one/(TTP-TMIX) ! if (me == 0) write(0,*) ' NO DOWNDRAFT FOR CLOUD TYPES' & @@ -365,7 +366,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & integer, dimension(100) :: ic - real(kind=kind_phys), parameter :: clwmin=1.0d-10 + real(kind=kind_phys), parameter :: clwmin=1.0e-10_r8 ! real(kind=kind_phys), allocatable :: ALFINT(:,:), uvi(:,:) & &, trcfac(:,:), rcu(:,:) @@ -392,8 +393,8 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & fscav_(i) = fscav(i) enddo endif - trcmin = -99999.0 - if (ntk-2 > 0) trcmin(ntk-2) = 1.0d-4 + trcmin = -99999.0_r8 + if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4_r8 !> - Initialize CCPP error handling variables @@ -487,23 +488,23 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & if (flipv) ll = kp1 -l ! Input variables are bottom to top! SGC = prsl(ipt,ll) * tem sgcs(l,ipt) = sgc - 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 ! + IF (SGC <= 0.050_r8) KRMIN = L +! IF (SGC <= 0.700_r8) KRMAX = L +! IF (SGC <= 0.800_r8) KRMAX = L + IF (SGC <= 0.760_r8) KRMAX = L +! IF (SGC <= 0.930_r8) KFMAX = L + IF (SGC <= 0.970_r8) KFMAX = L ! Commented on 20060202 +! IF (SGC <= 0.700_r8) kblmx = L ! Commented on 20101015 + IF (SGC <= 0.600_r8) kblmx = L ! +! IF (SGC <= 0.650_r8) kblmx = L ! Commented on 20060202 + IF (SGC <= 0.980_r8) kblmn = L ! ENDDO krmin = max(krmin,2) ! if (fix_ncld_hr) then !!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 - NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1800) + 0.10001d0 + NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1800) + 0.10001_r8 ! 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 @@ -513,7 +514,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & facdt = delt_c / dt else NCRND = min(nrcmax, (KRMAX-KRMIN+1)) - facdt = one / 3600.0d0 + facdt = one / 3600.0_r8 endif NCRND = min(nrcm,max(NCRND, 1)) ! @@ -537,7 +538,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & IF (NCRND > 0) THEN DO I=1,NCRND II = mod(i-1,nrcm) + 1 - IRND = (RANNUM(ipt,II)-0.0005d0)*(KCR-KRMIN+1) + IRND = (RANNUM(ipt,II)-0.0005_r8)*(KCR-KRMIN+1) IC(KFX+I) = IRND + KRMIN ENDDO ENDIF @@ -582,7 +583,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & if (ntr > 0) then ! tracers such as O3, dust etc do n=1,ntr uvi(l,n) = ccin(ipt,ll,n+2) - if (abs(uvi(l,n)) < 1.0d-20) uvi(l,n) = zero + if (abs(uvi(l,n)) < 1.0e-20_r8) uvi(l,n) = zero enddo endif enddo @@ -593,7 +594,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & phi_h(LL) = phii(ipt,L) enddo ! - if (ccin(ipt,1,2) <= -998.0) then ! input ice/water are together + if (ccin(ipt,1,2) <= -998.0_r8) then ! input ice/water are together do l=1,k ll = kp1 -l tem = ccin(ipt,ll,1) & @@ -631,7 +632,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & if (ntr > 0) then ! tracers such as O3, dust etc do n=1,ntr uvi(l,n) = ccin(ipt,l,n+2) - if (abs(uvi(l,n)) < 1.0d-20) uvi(l,n) = zero + if (abs(uvi(l,n)) < 1.0e-20_r8) uvi(l,n) = zero enddo endif enddo @@ -641,7 +642,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & phi_h(L) = phii(ipt,L) ENDDO ! - if (ccin(ipt,1,2) <= -998.0) then ! input ice/water are together + if (ccin(ipt,1,2) <= -998.0_r8) then ! input ice/water are together do l=1,k tem = ccin(ipt,l,1) & & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) @@ -688,7 +689,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvd=',dtvd(:,1) - if (abs(dtvd(2,1)) > 1.0d-10) then + if (abs(dtvd(2,1)) > 1.0e-10_r8) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) alfint(l,1) = one - half*(tem1 + tem2)/(one + tem2) ! for h @@ -702,7 +703,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvd2=',dtvd(:,2) - if (abs(dtvd(2,2)) > 1.0d-10) then + if (abs(dtvd(2,2)) > 1.0e-10_r8) then tem1 = dtvd(1,2) / dtvd(2,2) tem2 = abs(tem1) alfint(l,2) = one - half*(tem1 + tem2)/(one + tem2) ! for q @@ -713,7 +714,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvd3=',dtvd(:,3) - if (abs(dtvd(2,3)) > 1.0d-10) then + if (abs(dtvd(2,3)) > 1.0e-10_r8) then tem1 = dtvd(1,3) / dtvd(2,3) tem2 = abs(tem1) alfint(l,3) = one - half*(tem1 + tem2)/(one + tem2) ! for ql @@ -724,7 +725,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvd4=',dtvd(:,4) - if (abs(dtvd(2,4)) > 1.0d-10) then + if (abs(dtvd(2,4)) > 1.0e-10_r8) then tem1 = dtvd(1,4) / dtvd(2,4) tem2 = abs(tem1) alfint(l,4) = one - half*(tem1 + tem2)/(one + tem2) ! for qi @@ -741,7 +742,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvdn=',dtvd(:,1),' n=',n,' l=',l - if (abs(dtvd(2,1)) > 1.0d-10) then + if (abs(dtvd(2,1)) > 1.0e-10_r8) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) alfint(l,n+4) = one - half*(tem1 + tem2)/(one + tem2) ! for tracers @@ -850,7 +851,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & FLXD(L) = zero enddo ! - TLA = -10.0d0 + TLA = -10.0_r8 ! qiid = qii(ib) ! cloud top level ice before convection qlid = qli(ib) ! cloud top level water before convection @@ -930,7 +931,7 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! ENDDO ! End of the NC loop! ! - RAINC(ipt) = rain * 0.001d0 ! Output rain is in meters + RAINC(ipt) = rain * 0.001_r8 ! Output rain is in meters ktop(ipt) = kp1 kbot(ipt) = 0 @@ -944,9 +945,9 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & ! clw(i) = max(clw(i), zero) ! cli(i) = max(cli(i), zero) - 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 + if (sgcs(l,ipt) < 0.93_r8 .and. abs(tcu(l)) > one_m10) then +! if (sgcs(l,ipt) < 0.90_r8 .and. tcu(l) .ne. zero) then +! if (sgcs(l,ipt) < 0.85_r8 .and. tcu(l) .ne. zero) then kcnv(ipt) = 1 endif ! New test for convective clouds ! added in 08/21/96 @@ -972,18 +973,18 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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.d-10,QLCN(ipt,ll)+QICN(ipt,ll)) + & / max(1.0e-10_r8,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.d-10,qii(l)+qli(l)) + CNV_FICE(ipt,ll) = qii(l)/max(1.0e-10_r8,qii(l)+qli(l)) endif - cf_upi(ipt,ll) = max(zero,min(0.02d0*log(one+ & - & 500.0d0*ud_mf(ipt,ll)/dt), cfmax)) + cf_upi(ipt,ll) = max(zero,min(0.02_r8*log(one+ & + & 500.0_r8*ud_mf(ipt,ll)/dt), cfmax)) ! & 500*ud_mf(ipt,ll)/dt), 0.60)) 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.d-12)*prsl(ipt,ll)) + & (dt*max(cf_upi(ipt,ll),1.0e-12_r8)*prsl(ipt,ll)) endif if (ntr > 0) then @@ -1023,21 +1024,21 @@ subroutine rascnv_run(IM, IX, k, ntr, dt, dtf & 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.d-10,QLCN(ipt,l)+QICN(ipt,l)) + & / max(1.0e-10_r8,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.d-10,qii(l)+qli(l)) + CNV_FICE(ipt,l) = qii(l)/max(1.0e-10_r8,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.02d0*log(one+ & - & 500.d0*ud_mf(ipt,l)/dt), cfmax)) + cf_upi(ipt,l) = max(zero,min(0.02_r8*log(one+ & + & 500.0_r8*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.d-12)*prsl(ipt,l)) + & (dt*max(cf_upi(ipt,l),1.0e-12_r8)*prsl(ipt,l)) endif if (ntr > 0) then @@ -1140,33 +1141,33 @@ SUBROUTINE CLOUD( & ! IMPLICIT NONE ! - real (kind=kind_phys), parameter :: RHMAX=1.0d0 & ! MAX RELATIVE HUMIDITY - &, QUAD_LAM=1.0d0 & ! MASK FOR QUADRATIC LAMBDA - &, RHRAM=0.05d0 & ! PBL RELATIVE HUMIDITY RAMP -! &, RHRAM=0.15d0 !& ! PBL RELATIVE HUMIDITY RAMP - &, HCRITD=4000.0d0 & ! Critical Moist Static Energy for Deep clouds - &, HCRITS=2000.0d0 & ! Critical Moist Static Energy for Shallow clouds - &, pcrit_lcl=250.0d0 & ! Critical pressure difference between boundary layer top + real (kind=kind_phys), parameter :: RHMAX=1.0_r8 & ! MAX RELATIVE HUMIDITY + &, QUAD_LAM=1.0_r8 & ! MASK FOR QUADRATIC LAMBDA + &, RHRAM=0.05_r8 & ! PBL RELATIVE HUMIDITY RAMP +! &, RHRAM=0.15_r8 !& ! PBL RELATIVE HUMIDITY RAMP + &, HCRITD=4000.0_r8 & ! Critical Moist Static Energy for Deep clouds + &, HCRITS=2000.0_r8 & ! Critical Moist Static Energy for Shallow clouds + &, pcrit_lcl=250.0_r8 & ! Critical pressure difference between boundary layer top ! layer top and lifting condensation level (hPa) -! &, hpert_fac=1.01d0 !& ! Perturbation on hbl when ctei=.true. -! &, hpert_fac=1.005d0 !& ! Perturbation on hbl when ctei=.true. - &, qudfac=quad_lam*half & - &, shalfac=3.0d0 & -! &, qudfac=quad_lam*pt25, shalfac=3.0 !& ! Yogesh's - &, c0ifac=0.07d0 & ! following Han et al, 2016 MWR - &, dpnegcr = 150.0d0 -! &, dpnegcr = 100.0d0 -! &, dpnegcr = 200.0d0 -! - real(kind=kind_phys), parameter :: ERRMIN=0.0001d0 & - &, ERRMI2=0.1d0*ERRMIN & -! &, rainmin=1.0d-9 !& - &, rainmin=1.0d-8 & - &, oneopt9=1.0d0/0.09d0 & - &, oneopt4=1.0d0/0.04d0 - real(kind=kind_phys), parameter :: almax=1.0d-2 & - &, almin1=0.0d0, almin2=0.0d0 - real(kind=kind_phys), parameter :: bldmax=300.0d0, bldmin=25.0d0 +! &, hpert_fac=1.01_r8 !& ! Perturbation on hbl when ctei=.true. +! &, hpert_fac=1.005_r8 !& ! Perturbation on hbl when ctei=.true. + &, qudfac=quad_lam*half & + &, shalfac=3.0_r8 & +! &, qudfac=quad_lam*pt25, shalfac=3.0_r8 !& ! Yogesh's + &, c0ifac=0.07_r8 & ! following Han et al, 2016 MWR + &, dpnegcr = 150.0_r8 +! &, dpnegcr = 100.0_r8 +! &, dpnegcr = 200.0_r8 +! + real(kind=kind_phys), parameter :: ERRMIN=0.0001_r8 & + &, ERRMI2=0.1_r8*ERRMIN & +! &, rainmin=1.0e-9_r8 !& + &, rainmin=1.0e-8_r8 & + &, oneopt9=one/0.09_r8 & + &, oneopt4=one/0.04_r8 + real(kind=kind_phys), parameter :: almax=1.0e-2_r8 & + &, almin1=0.0_r8, almin2=0.0_r8 + real(kind=kind_phys), parameter :: bldmax=300.0_r8, bldmin=25.0_r8 ! ! INPUT ARGUMENTS @@ -1371,13 +1372,13 @@ SUBROUTINE CLOUD( & ! To determine KBL internally -- If KBL is defined externally ! the following two loop should be skipped ! - if (sgcs(kd) < 0.5d0) then + if (sgcs(kd) < 0.5_r8) then hcrit = hcritd - elseif (sgcs(kd) > 0.65d0) then + elseif (sgcs(kd) > 0.65_r8) then hcrit = hcrits else - hcrit = (hcrits*(sgcs(kd)-0.5d0) + hcritd*(0.65d0-sgcs(kd)))& - & * (one/0.15d0) + hcrit = (hcrits*(sgcs(kd)-0.5_r8) + hcritd*(0.65_r8-sgcs(kd)))& + & * (one/0.15_r8) endif IF (CALKBL) THEN KTEM = MAX(KD+1, KBLMX) @@ -1461,7 +1462,7 @@ SUBROUTINE CLOUD( & ii = max(kbl,kd1) kbl = max(klcl,kd1) - tem = min(50.0d0,max(10.0d0,(prl(kmaxp1)-prl(kd))*0.10d0)) + tem = min(50.0_r8,max(10.0_r8,(prl(kmaxp1)-prl(kd))*0.10_r8)) if (prl(kmaxp1) - prl(ii) > tem .and. ii > kbl) kbl = ii @@ -1521,7 +1522,7 @@ SUBROUTINE CLOUD( & ! shal_fac = one ! if (prl(kbl)-prl(kd) < 300.0 .and. kmax == k) shal_fac = shalfac - if (prl(kbl)-prl(kd) < 350.0d0 .and. kmax == k) shal_fac = shalfac + if (prl(kbl)-prl(kd) < 350.0_r8 .and. kmax == k) shal_fac = shalfac DO L=Kmax,KD,-1 IF (L >= KBL) THEN ETA(L) = (PRL(Kmaxp1)-PRL(L)) * PRISM @@ -1583,7 +1584,7 @@ SUBROUTINE CLOUD( & endif enddo ! - if (lcon == kd .or. kbl <= kd .or. prl(kbl)-prsm(lcon) > 150.0d0) & + if (lcon == kd .or. kbl <= kd .or. prl(kbl)-prsm(lcon) > 150.0_r8) & & return ! TX1 = RHFACS - QBL / TX1 ! Average RH @@ -1593,9 +1594,9 @@ SUBROUTINE CLOUD( & IF (.NOT. cnvflg) RETURN ! - RHC = MAX(ZERO, MIN(ONE, EXP(-20.0d0*TX1) )) + RHC = MAX(ZERO, MIN(ONE, EXP(-20.0_r8*TX1) )) ! - wcbase = 0.1d0 + wcbase = 0.1_r8 if (ntrc > 0) then DO N=1,NTRC RBL(N) = ROI(Kmax,N) * ETA(Kmax) @@ -1752,13 +1753,13 @@ SUBROUTINE CLOUD( & HSU = HSU - ALM * TX3 ! CLP = ZERO - ALM = -100.0d0 + ALM = -100.0_r8 HOS = HOL(KD) QOS = QOL(KD) QIS = CIL(KD) QLS = CLL(KD) - cnvflg = HBL > HSU .and. abs(tx1) > 1.0d-4 + cnvflg = HBL > HSU .and. abs(tx1) > 1.0e-4_r8 !*********************************************************************** @@ -1775,7 +1776,7 @@ SUBROUTINE CLOUD( & if (tx2 == zero) then alm = - st2 / tx1 - if (alm > almax) alm = -100.0d0 + if (alm > almax) alm = -100.0_r8 else x00 = tx2 + tx2 epp = tx1 * tx1 - (x00+x00)*st2 @@ -1784,8 +1785,8 @@ SUBROUTINE CLOUD( & tem = sqrt(epp) tem1 = (-tx1-tem)*x00 tem2 = (-tx1+tem)*x00 - if (tem1 > almax) tem1 = -100.0d0 - if (tem2 > almax) tem2 = -100.0d0 + if (tem1 > almax) tem1 = -100.0_r8 + if (tem2 > almax) tem2 = -100.0_r8 alm = max(tem1,tem2) endif @@ -1856,12 +1857,12 @@ SUBROUTINE CLOUD( & ACR = zero TEM = PRL(KD1) - (PRL(KD1)-PRL(KD)) * CLP * HALF tx1 = PRL(KBL) - TEM - tx2 = min(900.0d0, max(tx1,100.0d0)) - tem1 = log(tx2*0.01d0) * oneolog10 + tx2 = min(900.0_r8, max(tx1,100.0_r8)) + tem1 = log(tx2*0.01_r8) * oneolog10 tem2 = one - tem1 if ( kdt == 1 ) then -! rel_fac = (dt * facdt) / (tem1*12.0d0 + tem2*3.0) - rel_fac = (dt * facdt) / (tem1*6.0d0 + tem2*adjts_s) +! rel_fac = (dt * facdt) / (tem1*12.0_r8 + tem2*3.0) + rel_fac = (dt * facdt) / (tem1*6.0_r8 + tem2*adjts_s) else rel_fac = (dt * facdt) / (tem1*adjts_d + tem2*adjts_s) endif @@ -1870,7 +1871,7 @@ SUBROUTINE CLOUD( & rel_fac = max(zero, min(half,rel_fac)) IF (CRTFUN) THEN - iwk = tem*0.02d0 - 0.999999999d0 + iwk = tem*0.02_r8 - 0.999999999_r8 iwk = MAX(1, MIN(iwk, 16)) ACR = tx1 * (AC(iwk) + tem * AD(iwk)) * CCWF ENDIF @@ -2043,7 +2044,7 @@ SUBROUTINE CLOUD( & ! CALCUP = .FALSE. - TEM = max(0.05d0, MIN(CD*200.0d0, MAX_NEG_BOUY)) + TEM = max(0.05_r8, MIN(CD*200.0_r8, MAX_NEG_BOUY)) IF (.not. cnvflg .and. WFN > ACR .and. & & dpneg < dpnegcr .and. AKM <= TEM) CALCUP = .TRUE. @@ -2086,7 +2087,7 @@ SUBROUTINE CLOUD( & ENDIF PL = (PRL(KD1) + PRL(KD))*HALF - IF (TRAIN > 1.0d-4 .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. + IF (TRAIN > 1.0e-4_r8 .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. ENDIF ! IF (DDFT) THEN ! Downdraft scheme based on (Cheng and Arakawa, 1997) @@ -2401,7 +2402,7 @@ SUBROUTINE CLOUD( & ! sigf(kd) = max(zero, min(one, tx1 * tx1)) ! endif if (do_aw) then - tx1 = (0.2d0 / max(alm, 1.0d-5)) + tx1 = (0.2_r8 / max(alm, 1.0e-5_r8)) tx2 = one - min(one, pi * tx1 * tx1 / area) tx2 = tx2 * tx2 @@ -2525,8 +2526,8 @@ SUBROUTINE CLOUD( & endif enddo tem = tem + amb * dof * sigf(kbl) - tem = tem * (3600.0d0/dt) - tem1 = sqrt(max(one, min(100.0d0,(6.25d10/max(area,one))))) ! 20110530 + tem = tem * (3600.0_r8/dt) + tem1 = sqrt(max(one, min(100.0_r8,(6.25e10_r8/max(area,one))))) ! 20110530 clfrac = max(ZERO, min(half, rknob*clf(tem)*tem1)) cldfrd = clfrac @@ -2573,7 +2574,7 @@ SUBROUTINE CLOUD( & tem4 = zero if (tx1 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778d0 ) ) + & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778_r8 )) ACTEVAP = MIN(TX1, TEM4*CLFRAC) @@ -2581,7 +2582,7 @@ SUBROUTINE CLOUD( & ! tem4 = zero if (tx2 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778d0 ) ) + & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778_r8 )) TEM4 = min(MIN(TX2, TEM4*CLDFRD), potevap-actevap) if (tx2 < rainmin*dt) tem4 = min(tx2, potevap-actevap) ! @@ -2650,7 +2651,7 @@ SUBROUTINE CLOUD( & ! following Liu et al. [JGR,2001] Eq 1 if (FSCAV_(N) > zero) then - DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001d0) + DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001_r8) FNOSCAV = exp(- FSCAV_(N) * DELZKM) else FNOSCAV = one @@ -2660,7 +2661,7 @@ SUBROUTINE CLOUD( & & * FNOSCAV DO L=KD1,K if (FSCAV_(N) > zero) then - DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001d0) + DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001_r8) FNOSCAV = exp(- FSCAV_(N) * DELZKM) endif lm1 = l - 1 @@ -2779,7 +2780,7 @@ SUBROUTINE DDRFT( & &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1 & &, IDW, IDH, IDN(K), idnm, itr ! - parameter (ERRMIN=0.0001d0, ERRMI2=0.1d0*ERRMIN) + parameter (ERRMIN=0.0001_r8, ERRMI2=0.1_r8*ERRMIN) ! parameter (ERRMIN=0.00001, ERRMI2=0.1*ERRMIN) ! ! real (kind=kind_phys), parameter :: PIINV=one/PI, pio2=half*pi @@ -2789,9 +2790,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.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 (AA1=1.0_r8, BB1=1.0_r8, CC1=1.0_r8, DD1=1.0_r8, & + & F3=CC1, F5=1.0_r8) + parameter (QRMIN=1.0e-6_r8, WC2MIN=0.01_r8, 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) @@ -2800,12 +2801,12 @@ SUBROUTINE DDRFT( & &, itrmin=15, itrmnd=12, numtla=2 ! uncentering for vvel in dd - real(kind=kind_phys), parameter :: ddunc1=0.25d0 & + real(kind=kind_phys), parameter :: ddunc1=0.25_r8 & &, ddunc2=one-ddunc1 & ! &, ddunc1=0.4, ddunc2=one-ddunc1 & ! &, ddunc1=0.3, ddunc2=one-ddunc1 & - &, VTPEXP=-0.3636d0 & - &, VTP=36.34d0*SQRT(1.2d0)*(0.001d0)**0.1364d0 + &, VTPEXP=-0.3636_r8 & + &, VTP=36.34_r8*SQRT(1.2_r8)*(0.001_r8)**0.1364_r8 ! ! real(kind=kind_phys) EM(K*K), ELM(K) real(kind=kind_phys) ELM(K), AA(KD:K,KD:KP1), QW(KD:K,KD:K) & @@ -2830,7 +2831,7 @@ SUBROUTINE DDRFT( & CLDFRD = zero RNTP = zero DOF = zero - ERRQ = 10.0d0 + ERRQ = 10.0_r8 RNB = zero RNT = zero TX2 = PRL(KBL) @@ -2861,7 +2862,7 @@ SUBROUTINE DDRFT( & ENDDO if (kk /= kbl) then do l=kk,kbl - buy(l) = 0.9d0 * buy(l-1) + buy(l) = 0.9_r8 * buy(l-1) enddo endif ! @@ -2869,24 +2870,24 @@ SUBROUTINE DDRFT( & qrpi(l) = buy(l) enddo do l=kd1,kb1 - buy(l) = 0.25d0 * (qrpi(l-1)+qrpi(l)+qrpi(l)+qrpi(l+1)) + buy(l) = 0.25_r8 * (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.0d0 + tx1 - prl(kp1) + tx1 = 1000.0_r8 + 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.2d0) + F2 = (BB1+BB1)*ONEBG/(PI*0.2_r8) ! WCMIN = SQRT(WC2MIN) ! WCBASE = WCMIN ! ! del_tla = TLA * 0.2 ! del_tla = TLA * 0.25 - del_tla = TLA * 0.3d0 + del_tla = TLA * 0.3_r8 TLA = TLA - DEL_TLA ! DO L=KD,K @@ -2947,15 +2948,15 @@ 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.1d0 .or. tla > 45.0d0) cycle + if (errq < 0.1_r8 .or. tla > 45.0_r8) cycle ! tla = tla + del_tla STLA = SIN(TLA*deg2rad) ! sine of tilting angle CTL2 = one - STLA * STLA ! cosine square of tilting angle ! - STLA = F2 * STLA * AL2 - CTL2 = DD1 * CTL2 - CTL3 = 0.1364d0 * CTL2 + STLA = F2 * STLA * AL2 + CTL2 = DD1 * CTL2 + CTL3 = 0.1364_r8 * CTL2 ! DO L=KD,K RNF(L) = zero @@ -3018,8 +3019,8 @@ SUBROUTINE DDRFT( & VRW(1) = F3*WVL(KD) - CTL2*VT(1) BUD(KD) = STLA * TX6 * QRB(KD) * half RNF(KD) = BUD(KD) - DOF = 1.1364d0 * BUD(KD) * QRPI(KD) - DOFW = -BUD(KD) * STLT(KD) + DOF = 1.1364_r8 * BUD(KD) * QRPI(KD) + DOFW = -BUD(KD) * STLT(KD) ! RNT = TRW(1) * VRW(1) TX2 = zero @@ -3052,8 +3053,8 @@ SUBROUTINE DDRFT( & ! QA(2) = DOF WA(2) = DOFW - DOF = 1.1364d0 * BUD(L) * QRPI(L) - DOFW = -BUD(L) * STLT(L) + DOF = 1.1364_r8 * BUD(L) * QRPI(L) + DOFW = -BUD(L) * STLT(L) ! RNF(LL) = RNF(LL) + QQQ * ST1 RNF(L) = QQQ * QRT(L) @@ -3123,8 +3124,8 @@ SUBROUTINE DDRFT( & QA(2) = DOF WA(2) = DOFW - DOF = 1.1364d0 * BUD(L) * QRPI(L) - DOFW = -BUD(L) * STLT(L) + DOF = 1.1364_r8 * BUD(L) * QRPI(L) + DOFW = -BUD(L) * STLT(L) ! RNF(LL) = RNF(LL) + ST1 ! @@ -3258,7 +3259,7 @@ SUBROUTINE DDRFT( & ENDDO ! ! tem = 0.5 - if (tx2 > one .and. abs(errq-tx2) > 0.1d0) then + if (tx2 > one .and. abs(errq-tx2) > 0.1_r8) then tem = half !! elseif (tx2 < 0.1) then !! tem = 1.2 @@ -3281,17 +3282,17 @@ SUBROUTINE DDRFT( & ENDIF ELSE TEM = ERRQ - TX2 -! IF (TEM < ZERO .AND. ERRQ > 0.1d0) THEN - IF (TEM < ZERO .AND. ERRQ > 0.5d0) THEN +! IF (TEM < ZERO .AND. ERRQ > 0.1_r8) THEN + IF (TEM < ZERO .AND. ERRQ > 0.5_r8) THEN ! IF (TEM < ZERO .and. & -! & (ntla < numtla .or. ERRQ > 0.5d0)) THEN +! & (ntla < numtla .or. ERRQ > 0.5_r8)) THEN SKPUP = .TRUE. ! No convergence ! - ERRQ = 10.0d0 ! No rain profile! + ERRQ = 10.0_r8 ! No rain profile! !!!! ELSEIF (ABS(TEM) < ERRMI2 .OR. TX2 < ERRMIN) THEN ELSEIF (TX2 < ERRMIN) THEN SKPUP = .TRUE. ! Converges ! ERRQ = zero ! Rain profile exists! - elseif (tem < zero .and. errq < 0.1d0) then + elseif (tem < zero .and. errq < 0.1_r8) then skpup = .true. ! if (ntla == numtla .or. tem > -0.003) then errq = zero @@ -3309,7 +3310,7 @@ SUBROUTINE DDRFT( & ! ENDDO ! End of the ITR Loop!! ! - IF (ERRQ < 0.1d0) THEN + IF (ERRQ < 0.1_r8) THEN DDFT = .TRUE. RNB = - RNB ! do l=kd1,kb1-1 @@ -3330,7 +3331,7 @@ SUBROUTINE DDRFT( & TX1 = TX1 + RNF(L) ENDDO TX1 = TRAIN / (TX1+RNT+RNB) - IF (ABS(TX1-one) < 0.2d0) THEN + IF (ABS(TX1-one) < 0.2_r8) THEN RNT = MAX(RNT*TX1,ZERO) RNB = RNB * TX1 DO L=KD,KB1 @@ -3340,7 +3341,7 @@ SUBROUTINE DDRFT( & ELSE DDFT = .FALSE. - ERRQ = 10.0d0 + ERRQ = 10.0_r8 ENDIF ENDIF ! @@ -3364,7 +3365,7 @@ SUBROUTINE DDRFT( & WCB(L) = zero ENDDO ! - ERRQ = 10.0d0 + ERRQ = 10.0_r8 ! At this point stlt contains inverse of updraft vertical velocity 1/Wu. KK = MAX(KB1,KD1) @@ -3410,9 +3411,9 @@ SUBROUTINE DDRFT( & IF (RNT > zero) THEN if (TX1 > zero) THEN QRP(KD) = (RPART*RNT / (ROR(KD)*TX1*GMS(KD))) & - & ** (one/1.1364d0) + & ** (one/1.1364_r8) else - tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364d0) + tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364_r8) endif RNTP = (one - RPART) * RNT BUY(KD) = - ROR(KD) * TX1 * QRP(KD) @@ -3473,7 +3474,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.0d0*EKNOB) + TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.0_r8*EKNOB) ! DOFW = one / (WA(3) * (one + NU*WA(2))) ! 1.0 / TVbar! ! @@ -3481,7 +3482,7 @@ SUBROUTINE DDRFT( & HOD(L) = HOD(L-1) QOD(L) = QOD(L-1) ! - ERRQ = 10.0d0 + ERRQ = 10.0_r8 ! IF (L <= KBL) THEN @@ -3506,7 +3507,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.0d0) + WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0_r8) ENDIF WVL(L) = MAX(ONE_M2, WVL(L)) TRW(1) = TRW(1) * half @@ -3634,9 +3635,9 @@ SUBROUTINE DDRFT( & ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) TEM2 = ROR(L) * QRP(L) CALL QRABF(TEM2,QRAF,QRBF) - TEM6 = TX5 * (1.6d0 + 124.9d0 * QRAF) * QRBF * TX4 + TEM6 = TX5 * (1.6_r8 + 124.9_r8 * QRAF) * QRBF * TX4 ! - CE = TEM6 * ST2 / ((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) + CE = TEM6 * ST2 / ((5.4e5_r8*ST2 + 2.55e6_r8)*(ETD(L)+DDZ)) ! TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) TEM3 = (one + TEM1) * QHS * (QOD(L)+CE) @@ -3647,7 +3648,7 @@ SUBROUTINE DDRFT( & ! second iteration ! ! ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - CE = TEM6 * ST2 / ((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) + CE = TEM6 * ST2 / ((5.4e5_r8*ST2 + 2.55e6_r8)*(ETD(L)+DDZ)) ! CEE = CE * (ETD(L)+DDZ) ! @@ -3668,7 +3669,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.1364d0) + & ** (one/1.1364_r8) ELSE QRP(L) = zero ENDIF @@ -3695,7 +3696,7 @@ SUBROUTINE DDRFT( & ! WVL(L) = 0.5*tem1 ! WVL(L) = 0.1*tem1 ! WVL(L) = 0.0 - WVL(L) = 1.0d-10 + WVL(L) = 1.0e-10_r8 else WVL(L) = half*(WVL(L)+TEM1) endif @@ -3709,7 +3710,7 @@ SUBROUTINE DDRFT( & ! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN - IF (ETD(L-1) == zero .AND. ERRQ > 0.2d0) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.2_r8) THEN ROR(L) = BUD(KD) ETD(L) = zero WVL(L) = zero @@ -3721,7 +3722,7 @@ SUBROUTINE DDRFT( & TX5 = TX9 else TX5 = (STLT(KB1) * QRT(KB1) & - & + STLT(KBL) * QRB(KB1)) * (0.5d0*FAC) + & + STLT(KBL) * QRB(KB1)) * (0.5_r8*FAC) endif EVP(L-1) = zero @@ -3730,14 +3731,14 @@ SUBROUTINE DDRFT( & ! IF (QA(1) > 0.0) THEN QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (one/1.1364d0) + & ** (one/1.1364_r8) ! 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.1d0) THEN + IF(DEL_ETA < zero .AND. ERRQ > 0.1_r8) THEN ROR(L) = BUD(KD) ETD(L) = zero WVL(L) = zero @@ -3764,9 +3765,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.6d0 + 124.9d0 * QRAF) * QRBF * TX4 + TEM6 = TX5 * (1.6_r8 + 124.9_r8 * QRAF) * QRBF * TX4 ! - CE = TEM6*ST2/((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) + CE = TEM6*ST2/((5.4e5_r8*ST2 + 2.55e6_r8)*(ETD(L)+DDZ)) ! TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) @@ -3777,7 +3778,7 @@ SUBROUTINE DDRFT( & ! second iteration ! ! ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - CE = TEM6*ST2/((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) + CE = TEM6*ST2/((5.4e5_r8*ST2 + 2.55e6_r8)*(ETD(L)+DDZ)) ! CEE = CE * (ETD(L)+DDZ) ! @@ -3830,7 +3831,7 @@ SUBROUTINE DDRFT( & ! ENDDO ! End of the iteration loop for a given L! IF (L <= K) THEN - IF (ETD(L-1) == zero .AND. ERRQ > 0.1d0 .and. l <= kbl) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.1_r8 .and. l <= kbl) THEN !!! & .AND. ERRQ > ERRMIN*10.0 .and. l <= kbl) THEN ! & .AND. ERRQ > ERRMIN*10.0) THEN ROR(L) = BUD(KD) @@ -3853,7 +3854,7 @@ SUBROUTINE DDRFT( & ! IF (QA(1) > 0.0) THEN QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (one/1.1364d0) + & ** (one/1.1364_r8) ! ENDIF ETD(L) = zero WVL(L) = zero @@ -3884,7 +3885,7 @@ SUBROUTINE DDRFT( & ! not converge) , no downdraft is assumed ! ! IF (ERRQ > ERRMIN*100.0 .AND. IDN(idnm) == 99) & - IF (ERRQ > 0.1d0 .AND. IDN(idnm) == idnmax) DDFT = .FALSE. + IF (ERRQ > 0.1_r8 .AND. IDN(idnm) == idnmax) DDFT = .FALSE. ! DOF = zero IF (.NOT. DDFT) RETURN @@ -3988,7 +3989,7 @@ SUBROUTINE QSATCN(TT,P,Q,DQDT) real(kind=kind_phys) es, d, hlorv, W ! ! es = 10.0 * fpvs(tt) ! fpvs is in centibars! - es = min(p, 0.01d0 * fpvs(tt)) ! fpvs is in Pascals! + es = min(p, 0.01_r8 * fpvs(tt)) ! fpvs is in Pascals! ! D = one / max(p+epsm1*es,ONE_M10) D = one / (p+epsm1*es) ! @@ -4009,7 +4010,7 @@ SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) ! integer i ! - IF (TLA < 0.0d0) THEN + IF (TLA < 0.0_r8) THEN IF (PRES <= PLAC(1)) THEN TLA = TLAC(1) ELSEIF (PRES <= PLAC(2)) THEN @@ -4046,8 +4047,8 @@ SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) TEM = REFR(6) ENDIF ! - tem = 2.0d-4 / tem - al2 = min(4.0d0*tem, max(alm, tem)) + tem = 2.0e-4_r8 / tem + al2 = min(4.0_r8*tem, max(alm, tem)) ! RETURN end subroutine angrad @@ -4059,18 +4060,18 @@ SUBROUTINE SETQRP integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! XMIN = 1.0E-6 - XMIN = 0.0d0 - XMAX = 5.0d0 + XMIN = 0.0_r8 + XMAX = 5.0_r8 XINC = (XMAX-XMIN)/(NQRP-1) C2XQRP = one / XINC C1XQRP = one - XMIN*C2XQRP - TEM1 = 0.001d0 ** 0.2046d0 - TEM2 = 0.001d0 ** 0.525d0 + TEM1 = 0.001_r8 ** 0.2046_r8 + TEM2 = 0.001_r8 ** 0.525_r8 DO JX=1,NQRP X = XMIN + (JX-1)*XINC - TBQRP(JX) = X ** 0.1364d0 - TBQRA(JX) = TEM1 * X ** 0.2046d0 - TBQRB(JX) = TEM2 * X ** 0.525d0 + TBQRP(JX) = X ** 0.1364_r8 + TBQRA(JX) = TEM1 * X ** 0.2046_r8 + TBQRB(JX) = TEM2 * X ** 0.525_r8 ENDDO ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN @@ -4095,12 +4096,12 @@ end subroutine qrabf SUBROUTINE SETVTP implicit none - real(kind=kind_phys), parameter :: vtpexp=-0.3636d0, one=1.0d0 + real(kind=kind_phys), parameter :: vtpexp=-0.3636_r8, one=1.0_r8 real(kind=kind_phys) xinc,x,xmax,xmin integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN = 0.05d0 - XMAX = 1.5d0 + XMIN = 0.05_r8 + XMAX = 1.5_r8 XINC = (XMAX-XMIN)/(NVTP-1) C2XVTP = one / XINC C1XVTP = one - XMIN*C2XVTP @@ -4147,10 +4148,10 @@ real(kind=kind_phys) FUNCTION CLF(PRATE) implicit none real(kind=kind_phys) PRATE ! - 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 + real (kind=kind_phys), parameter :: ccf1=0.30_r8, ccf2=0.09_r8 & + &, ccf3=0.04_r8, ccf4=0.01_r8 & + &, pr1=1.0_r8, pr2=5.0_r8 & + &, pr3=20.0_r8 ! if (prate < pr1) then clf = ccf1 From f85730de98a126e7552b4bdc9d31ceb9c3ae067d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Apr 2020 10:58:03 +0000 Subject: [PATCH 09/30] updating to fix a potential snow bug --- physics/GFS_surface_composites.F90 | 36 +++++++++++++++++++----------- physics/sfc_cice.f | 22 ++++++++++++------ physics/sfc_cice.meta | 36 ++++++++++++++++++++++++++++++ 3 files changed, 74 insertions(+), 20 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index e12543328..22f5654a1 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -435,9 +435,10 @@ subroutine GFS_surface_composites_post_run ( hflx(i) = hflx_lnd(i) qss(i) = qss_lnd(i) tsfc(i) = tsfc_lnd(i) - !hice(i) = zero - !cice(i) = zero - !tisfc(i) = tsfc(i) + hice(i) = zero + cice(i) = zero + tisfc(i) = tsfc(i) + tsfco(i) = tsfc(i) elseif (islmsk(i) == 0) then zorl(i) = zorl_ocn(i) cd(i) = cd_ocn(i) @@ -465,6 +466,7 @@ subroutine GFS_surface_composites_post_run ( hice(i) = zero cice(i) = zero tisfc(i) = tsfc(i) + tsfcl(i) = tsfc(i) else ! islmsk(i) == 2 zorl(i) = zorl_ice(i) cd(i) = cd_ice(i) @@ -477,16 +479,6 @@ subroutine GFS_surface_composites_post_run ( fh2(i) = fh2_ice(i) stress(i) = stress_ice(i) !tsurf(i) = tsurf_ice(i) - if (.not. flag_cice(i)) then - tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - elseif (wet(i) .and. cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice - txi = cice(i) - txo = one - txi - evap(i) = txi * evap_ice(i) + txo * evap_ocn(i) - hflx(i) = txi * hflx_ice(i) + txo * hflx_ocn(i) - tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_ocn(i) - stress(i) = txi * stress_ice(i) + txo * stress_ocn(i) - endif cmm(i) = cmm_ice(i) chh(i) = chh_ice(i) gflx(i) = gflx_ice(i) @@ -499,6 +491,24 @@ subroutine GFS_surface_composites_post_run ( hflx(i) = hflx_ice(i) qss(i) = qss_ice(i) tsfc(i) = tsfc_ice(i) + tsfcl(i) = tsfc(i) + if (.not. flag_cice(i)) then + tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + elseif (wet(i) .and. cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_ocn(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_ocn(i) + tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_ocn(i) + stress(i) = txi * stress_ice(i) + txo * stress_ocn(i) + qss(i) = txi * qss_ice(i) + txo * qss_ocn(i) + ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_ocn(i) + endif + if (wet(i)) then + tsfco(i) = tsfc_ocn(i) + else + tsfco(i) = tsfc(i) + endif endif zorll(i) = zorl_lnd(i) diff --git a/physics/sfc_cice.f b/physics/sfc_cice.f index 9cb2b5f21..5fb61a7cc 100644 --- a/physics/sfc_cice.f +++ b/physics/sfc_cice.f @@ -44,9 +44,9 @@ subroutine sfc_cice_run & & ( im, cplflx, hvap, cp, rvrdm1, rd, & & t1, q1, cm, ch, prsl1, & & wind, flag_cice, flag_iter, dqsfc, dtsfc, & - & dusfc, dvsfc, & + & dusfc, dvsfc, snowd, & ! --- outputs: - & qsurf, cmm, chh, evap, hflx, stress, & + & qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep, & & errmsg, errflg & ) @@ -94,6 +94,8 @@ subroutine sfc_cice_run & use machine , only : kind_phys implicit none + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys real (kind=kind_phys), intent(in) :: hvap, cp, rvrdm1, rd ! --- inputs: @@ -103,12 +105,14 @@ subroutine sfc_cice_run & ! 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 + &, snowd logical, intent(in) :: flag_cice(im), flag_iter(im) ! --- outputs: - real (kind=kind_phys), dimension(im), intent(out) :: qsurf, & + real (kind=kind_phys), dimension(im), intent(inout) :: qsurf, & & cmm, chh, evap, hflx, stress + &, weasd, snwdph, ep ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -127,24 +131,28 @@ subroutine sfc_cice_run & ! if (.not. cplflx) return ! - cpinv = 1.0d0/cp - hvapi = 1.0d0/hvap + cpinv = one / cp + hvapi = one / hvap elocp = hvap/cp ! do i = 1, im if (flag_cice(i) .and. flag_iter(i)) then rho = prsl1(i) & - & / (rd * t1(i) * (1.0d0 + rvrdm1*max(q1(i), 1.0d-8))) + & / (rd * t1(i) * (one + rvrdm1*max(q1(i), 1.0e-8_kind_phys))) cmm(i) = wind(i) * cm(i) chh(i) = wind(i) * ch(i) * rho qsurf(i) = q1(i) + dqsfc(i) / (hvap*chh(i)) - tem = 1.0d0 / rho + tem = one / rho 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/physics/sfc_cice.meta b/physics/sfc_cice.meta index a1c57d4d9..3d26baf7a 100644 --- a/physics/sfc_cice.meta +++ b/physics/sfc_cice.meta @@ -159,6 +159,15 @@ kind = kind_phys intent = in optional = F +[snowd] + 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 + intent = in + optional = F [qsurf] standard_name = surface_specific_humidity_over_ice long_name = surface air saturation specific humidity over ice @@ -213,6 +222,33 @@ kind = kind_phys intent = inout optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_ice + long_name = surface upward potential latent heat flux over ice + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 02414491112c736f75081f26ad508c70925d265a Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Apr 2020 11:09:44 +0000 Subject: [PATCH 10/30] fixing some comment lines --- physics/sfc_cice.f | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/physics/sfc_cice.f b/physics/sfc_cice.f index 5fb61a7cc..2bda3a0c3 100644 --- a/physics/sfc_cice.f +++ b/physics/sfc_cice.f @@ -61,9 +61,9 @@ subroutine sfc_cice_run & ! ( im, cplflx, hvap, cp, rvrdm1, rd, ! ! t1, q1, cm, ch, prsl1, ! ! wind, flag_cice, flag_iter, dqsfc, dtsfc, ! -! dusfc, dvsfc, ! +! dusfc, dvsfc, snowd, ! ! outputs: ! -! qsurf, cmm, chh, evap, hflx, stress) ! +! qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep) ! ! ! ! ==================== defination of variables ==================== ! ! ! @@ -81,6 +81,7 @@ subroutine sfc_cice_run & ! dtsfc - real, sensible heat flux ! dusfc - real, zonal momentum stress ! dvsfc - real, meridional momentum stress +! snowd - real, snow depth from cice ! outputs: ! qsurf - real, specific humidity at sfc ! cmm - real, ? @@ -88,6 +89,9 @@ subroutine sfc_cice_run & ! 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 ===================== ! ! ! From 4694c008851cceb7ef1977b48d00067f49fca69d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Apr 2020 14:20:19 +0000 Subject: [PATCH 11/30] some minor change with same result --- physics/GFS_surface_composites.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 22f5654a1..ae9724844 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -86,13 +86,14 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl if (cice(i) >= min_lakeice) then icy(i) = .true. else - cice(i) = zero - islmsk = 0 + cice(i) = zero + islmsk(i) = 0 endif endif if (cice(i) < one ) then wet(i)=.true. ! some open ocean/lake water exists - if (.not. cplflx) tsfco(i) = max(tsfco(i), tisfc(i), tgice) + if (.not. cplflx .or. oceanfrac(i) == zero) & + tsfco(i) = max(tsfco(i), tisfc(i), tgice) end if else cice(i) = zero From e216116dbccb9b456a3c3eaf33d7bc5cca890725 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 28 Apr 2020 13:28:43 +0000 Subject: [PATCH 12/30] update consistent with ipd --- physics/sfc_cice.f | 1 + 1 file changed, 1 insertion(+) diff --git a/physics/sfc_cice.f b/physics/sfc_cice.f index 2bda3a0c3..d2d0ae631 100644 --- a/physics/sfc_cice.f +++ b/physics/sfc_cice.f @@ -155,6 +155,7 @@ subroutine sfc_cice_run & stress(i) = sqrt(dusfc(i)*dusfc(i) + dvsfc(i)*dvsfc(i)) * tem weasd(i) = snowd(i) * 1000.0_kind_phys + snwdph(i) = weasd(i) ! snow depth in mm snwdph(i) = weasd(i) * dsi ! snow depth in mm ep(i) = evap(i) endif From cdac822b69ce9691a0380e39b384383f0d718300 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 29 Apr 2020 13:09:25 +0000 Subject: [PATCH 13/30] testing an alternate option in ccpp --- physics/sfc_cice.f | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/physics/sfc_cice.f b/physics/sfc_cice.f index d2d0ae631..f845f6091 100644 --- a/physics/sfc_cice.f +++ b/physics/sfc_cice.f @@ -154,9 +154,12 @@ subroutine sfc_cice_run & 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) ! snow depth in mm - 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 d61ecbe02a64c872212644cd472de77ee73605e2 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 30 Apr 2020 02:00:14 +0000 Subject: [PATCH 14/30] some additional updates to the code --- physics/GFS_MP_generic.F90 | 13 +- physics/dcyc2.f | 6 +- physics/gcm_shoc.F90 | 163 +++++++++++----------- physics/get_prs_fv3.F90 | 7 +- physics/m_micro.F90 | 272 +++++++++++++++++++------------------ physics/sfc_sice.f | 14 +- 6 files changed, 239 insertions(+), 236 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index ffbe6ab9b..4baf24e8c 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -259,7 +259,9 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt !! and determine explicit rain/snow by snow/ice/graupel coming out directly from MP !! and convective rainfall from the cumulus scheme if the surface temperature is below !! \f$0^oC\f$. + if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson) then + ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP @@ -305,15 +307,12 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt rain(i) = zero rainc(i) = zero endif - tprcp(i) = max(zero, rain(i) ) ! clu: rain -> tprcp + tprcp(i) = max(zero, rain(i)) enddo - else + else ! not GFDL or MG or Thompson microphysics do i = 1, im - tprcp(i) = max(zero, rain(i) ) ! clu: rain -> tprcp - srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16_kind_phys) then - srflag(i) = one ! clu: set srflag to 'snow' (i.e. 1) - endif + tprcp(i) = max(zero, rain(i)) + srflag(i) = sr(i) enddo endif endif diff --git a/physics/dcyc2.f b/physics/dcyc2.f index c7a1ddd59..6174f7641 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -286,10 +286,10 @@ subroutine dcyc2t3_run & istsun(i) = zero enddo do it=1,nstl - cns = solang + (float(it)-0.5)*anginc + slag + cns = solang + (float(it)-0.5_kind_phys)*anginc + slag do i = 1, IM coszn = sdec*sinlat(i) + cdec*coslat(i)*cos(cns+xlon(i)) - xcosz(i) = xcosz(i) + max(0.0, coszn) + xcosz(i) = xcosz(i) + max(zero, coszn) if (coszn > czlimt) istsun(i) = istsun(i) + 1 enddo enddo @@ -334,7 +334,7 @@ subroutine dcyc2t3_run & if ( xcosz(i) > f_eps .and. coszen(i) > f_eps ) then xmu(i) = xcosz(i) / coszen(i) else - xmu(i) = 0.0 + xmu(i) = zero endif !> - adjust \a sfc net and downward SW fluxes for zenith angle changes. diff --git a/physics/gcm_shoc.F90 b/physics/gcm_shoc.F90 index 9baa61516..8e415fe75 100644 --- a/physics/gcm_shoc.F90 +++ b/physics/gcm_shoc.F90 @@ -10,6 +10,7 @@ module shoc private public shoc_run, shoc_init, shoc_finalize + integer, parameter :: r8 = kind_phys contains @@ -46,7 +47,7 @@ subroutine shoc_run (ix, nx, nzm, tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - real(kind=kind_phys), parameter :: epsq = 1.0d-20, zero=0.0d0, one=1.0d0 + real(kind=kind_phys), parameter :: epsq = 1.0e-20_r8, zero=0.0_r8, one=1.0_r8 integer :: i, k @@ -220,34 +221,34 @@ subroutine shoc_work (ix, nx, nzm, nz, dtn, & real, intent(in) :: prnum (nx,nzm) ! turbulent Prandtl number real, intent(inout) :: wthv_sec (ix,nzm) ! Buoyancy flux, K*m/s - real, parameter :: zero=0.0d0, one=1.0d0, half=0.5d0, two=2.0d0, eps=0.622d0, & - three=3.0d0, oneb3=one/three, twoby3=two/three, fourb3=twoby3+twoby3 - real, parameter :: sqrt2 = sqrt(two), twoby15 = two / 15.d0, & - nmin = 1.0d0, RI_cub = 6.4d-14, RL_cub = 1.0d-15, & - skew_facw=1.2d0, skew_fact=0.d0, & - tkhmax=300.d0, qcmin=1.0d-9 - real :: lsub, fac_cond, fac_fus, cpolv, fac_sub, ggri, kapa, gocp, & + real, parameter :: zero=0.0_r8, one=1.0_r8, half=0.5_r8, two=2.0_r8, eps=0.622_r8, & + three=3.0_r8, oneb3=one/three, twoby3=two/three, fourb3=twoby3+twoby3 + real, parameter :: sqrt2 = sqrt(two), twoby15 = two / 15.0_r8, & + nmin = 1.0_r8, RI_cub = 6.4e-14_r8, RL_cub = 1.0e-15_r8, & + skew_facw=1.2_r8, skew_fact=0.0_r8, & + tkhmax=300.0_r8, qcmin=1.0e-9_r8 + real :: lsub, fac_cond, fac_fus, cpolv, fac_sub, ggri, kapa, gocp, & rog, sqrtpii, epsterm, onebeps, onebrvcp ! 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 :: lambda = 0.04_r8 +! real, parameter :: min_tke = 1.0e-6_r8 ! Minumum TKE value, m**2/s**2 + real, parameter :: min_tke = 1.0e-4_r8 ! Minumum TKE value, m**2/s**2 +! real, parameter :: max_tke = 100.0_r8 ! Maximum TKE value, m**2/s**2 + real, parameter :: max_tke = 40.0_r8 ! 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 = 1000.0d0 +! real, parameter :: max_eddy_length_scale = 2000.0_r8 + real, parameter :: max_eddy_length_scale = 1000.0_r8 ! Maximum "return-to-isotropy" time scale, s - real, parameter :: max_eddy_dissipation_time_scale = 2000.d0 - real, parameter :: Pr = 1.0d0 ! Prandtl number + real, parameter :: max_eddy_dissipation_time_scale = 2000.0_r8 + real, parameter :: Pr = 1.0_r8 ! Prandtl number ! 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.1d0 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 + real, parameter :: pt19=0.19_r8, pt51=0.51_r8, pt01=0.01_r8, atmin=0.01_r8, atmax=one-atmin + real, parameter :: Cs = 0.15_r8, epsln=1.0e-6_r8 +! real, parameter :: Ck = 0.2_r8 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 + real, parameter :: Ck = 0.1_r8 ! 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 @@ -260,29 +261,29 @@ subroutine shoc_work (ix, nx, nzm, nz, dtn, & real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce ! real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce*3.0/0.7 -! real, parameter :: vonk=0.35 ! Von Karman constant - real, parameter :: vonk=0.4d0 ! Von Karman constant Moorthi - as in GFS - real, parameter :: tscale=400.0d0 ! time scale set based off of similarity results of BK13, s - real, parameter :: w_tol_sqd = 4.0d-04 ! Min vlaue of second moment of w -! real, parameter :: w_tol_sqd = 1.0e-04 ! Min vlaue of second moment of w - real, parameter :: w_thresh = 0.0d0, thresh = 0.0d0 - real, parameter :: w3_tol = 1.0d-20 ! Min vlaue of third moment of w +! real, parameter :: vonk=0.35 ! Von Karman constant + real, parameter :: vonk=0.4_r8 ! Von Karman constant Moorthi - as in GFS + real, parameter :: tscale=400.0_r8 ! time scale set based off of similarity results of BK13, s + real, parameter :: w_tol_sqd = 4.0e-04_r8 ! Min vlaue of second moment of w +! real, parameter :: w_tol_sqd = 1.0e-04_r8 ! Min vlaue of second moment of w + real, parameter :: w_thresh = 0.0_r8, thresh = 0.0_r8 + real, parameter :: w3_tol = 1.0e-20_r8 ! Min vlaue of third moment of w ! These parameters are a tie-in with a microphysical scheme ! Double check their values for the Zhao-Carr scheme. - real, parameter :: tbgmin = 233.16d0 ! Minimum temperature for cloud water., K (ZC) -! real, parameter :: tbgmin = 258.16d0 ! Minimum temperature for cloud water., K (ZC) -! real, parameter :: tbgmin = 253.16d0 ! Minimum temperature for cloud water., K - real, parameter :: tbgmax = 273.16d0 ! Maximum temperature for cloud ice, K + real, parameter :: tbgmin = 233.16_r8 ! Minimum temperature for cloud water., K (ZC) +! real, parameter :: tbgmin = 258.16_r8 ! Minimum temperature for cloud water., K (ZC) +! real, parameter :: tbgmin = 253.16_r8 ! Minimum temperature for cloud water., K + real, parameter :: tbgmax = 273.16_r8 ! Maximum temperature for cloud ice, K real, parameter :: a_bg = one/(tbgmax-tbgmin) ! ! Parameters to tune the second order moments- No tuning is performed currently -! real, parameter :: thl2tune = 2.0d0, qw2tune = 2.0d0, qwthl2tune = 2.0d0, & - real, parameter :: thl2tune = 1.0d0, qw2tune = 1.0d0, qwthl2tune = 1.0d0, & -! thl_tol = 1.0d-4, rt_tol = 1.0d-8, basetemp = 300.0d0 - thl_tol = 1.0d-2, rt_tol = 1.0d-4 +! real, parameter :: thl2tune = 2.0_r8, qw2tune = 2.0_r8, qwthl2tune = 2.0_r8, & + real, parameter :: thl2tune = 1.0_r8, qw2tune = 1.0_r8, qwthl2tune = 1.0_r8, & +! thl_tol = 1.0e-4_r8, rt_tol = 1.0e-8_r8, basetemp = 300.0_r8 + thl_tol = 1.0e-2_r8, rt_tol = 1.0e-4_r8 integer, parameter :: nitr=6 @@ -454,7 +455,7 @@ subroutine shoc_work (ix, nx, nzm, nz, dtn, & ! total_water(i,k) = qcl(i,k) + qci(i,k) + qv(i,k) - prespot = (100000.0d0*wrk) ** kapa ! Exner function + prespot = (100000.0_r8*wrk) ** kapa ! Exner function bet(i,k) = ggr/(tabs(i,k)*prespot) ! Moorthi thv(i,k) = thv(i,k)*prespot ! Moorthi ! @@ -636,8 +637,8 @@ subroutine tke_shoc() if (dis_opt > 0) then do i=1,nx - wrk = (zl(i,k)-zi(i,1)) / adzl(i,1) + 1.5d0 - cek(i) = (one + two / max((wrk*wrk - 3.3d0), 0.5d0)) * cefac + wrk = (zl(i,k)-zi(i,1)) / adzl(i,1) + 1.5_r8 + cek(i) = (one + two / max((wrk*wrk - 3.3_r8), 0.5_r8)) * cefac enddo else if (k == 1) then @@ -661,7 +662,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.0001d0) ! tkh is eddy thermal diffussivity + buoy_sgs = - (a_prod_bu+a_prod_bu) / (tkh(i,ku)+tkh(i,kd) + 0.0001_r8) ! tkh is eddy thermal diffussivity !Compute $c_k$ (variable Cee) for the TKE dissipation term following Deardorff (1980) @@ -669,7 +670,7 @@ subroutine tke_shoc() if (buoy_sgs <= zero) then smix = grd else - smix = min(grd,max(0.1d0*grd, 0.76d0*sqrt(tke(i,k)/(buoy_sgs+1.0d-10)))) + smix = min(grd,max(0.1_r8*grd, 0.76_r8*sqrt(tke(i,k)/(buoy_sgs+1.0e-10_r8)))) endif ratio = smix/grd @@ -811,9 +812,9 @@ subroutine eddy_length() ! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) do i=1,nx if (denom(i) > zero .and. numer(i) > zero) then - l_inf(i) = min(0.1d0 * (numer(i)/denom(i)), 100.0d0) + l_inf(i) = min(0.1_r8 * (numer(i)/denom(i)), 100.0_r8) else - l_inf(i) = 100.0d0 + l_inf(i) = 100.0_r8 endif enddo @@ -849,7 +850,7 @@ subroutine eddy_length() ! Find the in-cloud Brunt-Vaisalla frequency - omn = qcl(i,k) / (wrk+1.0d-20) ! Ratio of liquid water to total water + omn = qcl(i,k) / (wrk+1.0e-20_r8) ! 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 @@ -868,7 +869,7 @@ subroutine eddy_length() ! liquid/ice moist static energy static energy divided by cp? bbb = (one + epsv*qsatt-wrk-qpl(i,k)-qpi(i,k) & - + 1.61d0*tabs(i,k)*dqsat) / (one+lstarn*dqsat) + + 1.61_r8*tabs(i,k)*dqsat) / (one+lstarn*dqsat) ! Calculate Brunt-Vaisalla frequency using centered differences in the vertical @@ -918,7 +919,7 @@ subroutine eddy_length() wrk1 = one / (tscale*tkes*vonk*zl(i,k)) wrk2 = one / (tscale*tkes*l_inf(i)) wrk1 = wrk1 + wrk2 + pt01 * brunt2(i,k) / tke(i,k) - wrk1 = sqrt(one / max(wrk1,1.0d-8)) * (one/0.3d0) + wrk1 = sqrt(one / max(wrk1,1.0e-8_r8)) * (one/0.3_r8) ! smixt(i,k) = min(max_eddy_length_scale, 2.8284*sqrt(wrk1)/0.3) smixt(i,k) = min(max_eddy_length_scale, wrk1) @@ -989,7 +990,7 @@ subroutine eddy_length() ! The calculation below finds the integral in the Eq. 10 in BK13 for the current cloud conv_var = zero do kk=kl,ku - conv_var = conv_var+ 2.5d0*adzi(i,kk)*bet(i,kk)*wthv_sec(i,kk) + conv_var = conv_var+ 2.5_r8*adzi(i,kk)*bet(i,kk)*wthv_sec(i,kk) enddo conv_var = conv_var ** oneb3 @@ -1006,7 +1007,7 @@ subroutine eddy_length() wrk = conv_var/(depth*depth*sqrt(tke(i,kk))) & + pt01*brunt2(i,kk)/tke(i,kk) - smixt(i,kk) = min(max_eddy_length_scale, (one/0.3d0)*sqrt(one/wrk)) + smixt(i,kk) = min(max_eddy_length_scale, (one/0.3_r8)*sqrt(one/wrk)) enddo @@ -1053,7 +1054,7 @@ subroutine conv_scale() !********************************************************************** conv_vel2(i,k) = conv_vel2(i,k-1) & - + 2.5d0*adzi(i,k)*bet(i,k)*wthv_sec(i,k) + + 2.5_r8*adzi(i,k)*bet(i,k)*wthv_sec(i,k) enddo enddo @@ -1084,7 +1085,7 @@ subroutine check_eddy() do i=1,nx - wrk = 0.1d0*adzl(i,k) + wrk = 0.1_r8*adzl(i,k) ! Minimum 0.1 of local dz smixt(i,k) = max(wrk, min(max_eddy_length_scale,smixt(i,k))) @@ -1092,7 +1093,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) == zero .and. qcl(i,k) > zero .and. brunt(i,k) > 1.0d-4) then + if (qcl(i,kb) == zero .and. qcl(i,k) > zero .and. brunt(i,k) > 1.0e-4_r8) then !If just above the cloud top and atmosphere is stable, set to 0.1 of local dz smixt(i,k) = wrk endif @@ -1118,10 +1119,10 @@ subroutine canuto() ! cond, 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), & - 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)) + real, parameter :: c=7.0_r8, a0=0.52_r8/(c*c*(c-2.0_r8)), a1=0.87_r8/(c*c), & + a2=0.5_r8/c, a3=0.6_r8/(c*(c-2.0_r8)), a4=2.4_r8/(3.0_r8*c+5.0_r8), & + a5=0.6_r8/(c*(3.0_r8*c+5.0_r8)) +!Moorthi a5=0.6_r8/(c*(3.0_r8+5.0_r8*c)) ! do k=1,nzm do k=2,nzm @@ -1211,7 +1212,7 @@ subroutine canuto() omega0 = a4 / (one-a5*buoy_sgs2) omega1 = omega0 / (c+c) - omega2 = omega1*f3+(5.0d0/4.0d0)*omega0*f4 + omega2 = omega1*f3+(5.0_r8/4.0_r8)*omega0*f4 ! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) @@ -1234,7 +1235,7 @@ subroutine canuto() !aab ! Implemetation of the C01 approach in this subroutine is nearly complete @@ -1288,7 +1289,7 @@ subroutine assumed_pdf() diag_qi = zero pval = prsl(i,k) - pfac = pval * 1.0d-5 + pfac = pval * 1.0e-5_r8 pkap = pfac ** kapa ! Read in liquid/ice static energy, total water mixing ratio, @@ -1362,21 +1363,21 @@ subroutine assumed_pdf() ELSE !aab 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.4d0 - w2_2 = 0.4d0 + w2_1 = 0.4_r8 + w2_2 = 0.4_r8 ! 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.0d0*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) + aterm = max(atmin,min(half*(one-Skew_w*sqrt(one/(4.0_r8*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) onema = one - aterm sqrtw2t = sqrt(wrk) @@ -1415,8 +1416,8 @@ subroutine assumed_pdf() ! wrk4 = - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 wrk = three * (thl1_2-thl1_1) if (wrk /= zero) then - thl2_1 = thlsec * min(100.0d0,max(zero,(thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - thl2_2 = thlsec * min(100.0d0,max(zero,(-thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + thl2_1 = thlsec * min(100.0_r8,max(zero,(thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + thl2_2 = thlsec * min(100.0_r8,max(zero,(-thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 else thl2_1 = zero thl2_2 = zero @@ -1450,12 +1451,12 @@ subroutine assumed_pdf() ! Skew_qw = skew_facw*Skew_w - IF (tsign > 0.4d0) THEN + IF (tsign > 0.4_r8) THEN Skew_qw = skew_facw*Skew_w - ELSEIF (tsign <= 0.2d0) THEN + ELSEIF (tsign <= 0.2_r8) THEN Skew_qw = zero ELSE - Skew_qw = (skew_facw/0.2d0) * Skew_w * (tsign-0.2d0) + Skew_qw = (skew_facw/0.2_r8) * Skew_w * (tsign-0.2_r8) ENDIF wrk1 = qw1_1 * qw1_1 @@ -1465,8 +1466,8 @@ subroutine assumed_pdf() wrk = three * (qw1_2-qw1_1) if (wrk /= zero) then - qw2_1 = qwsec * min(100.0d0,max(zero,( qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - qw2_2 = qwsec * min(100.0d0,max(zero,(-qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + qw2_1 = qwsec * min(100.0_r8,max(zero,( qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + qw2_2 = qwsec * min(100.0_r8,max(zero,(-qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 else qw2_1 = zero qw2_2 = zero @@ -1512,18 +1513,18 @@ subroutine assumed_pdf() IF (Tl1_1 >= tbgmax) THEN lstarn1 = lcond esval = min(fpvsl(Tl1_1), pval) - qs1 = eps * esval / (pval-0.378d0*esval) + qs1 = eps * esval / (pval-0.378_r8*esval) ELSE IF (Tl1_1 <= tbgmin) THEN lstarn1 = lsub esval = min(fpvsi(Tl1_1), pval) - qs1 = epss * esval / (pval-0.378d0*esval) + qs1 = epss * esval / (pval-0.378_r8*esval) ELSE om1 = max(zero, min(one, a_bg*(Tl1_1-tbgmin))) lstarn1 = lcond + (one-om1)*lfus esval = min(fpvsl(Tl1_1), pval) esval2 = min(fpvsi(Tl1_1), pval) - qs1 = om1 * eps * esval / (pval-0.378d0*esval) & - + (one-om1) * epss * esval2 / (pval-0.378d0*esval2) + qs1 = om1 * eps * esval / (pval-0.378_r8*esval) & + + (one-om1) * epss * esval2 / (pval-0.378_r8*esval2) ENDIF ! beta1 = (rgas/rv)*(lstarn1/(rgas*Tl1_1))*(lstarn1/(cp*Tl1_1)) @@ -1542,18 +1543,18 @@ subroutine assumed_pdf() IF (Tl1_2 >= tbgmax) THEN lstarn2 = lcond esval = min(fpvsl(Tl1_2), pval) - qs2 = eps * esval / (pval-0.378d0*esval) + qs2 = eps * esval / (pval-0.378_r8*esval) ELSE IF (Tl1_2 <= tbgmin) THEN lstarn2 = lsub esval = min(fpvsi(Tl1_2), pval) - qs2 = epss * esval / (pval-0.378d0*esval) + qs2 = epss * esval / (pval-0.378_r8*esval) ELSE om2 = max(zero, min(one, a_bg*(Tl1_2-tbgmin))) lstarn2 = lcond + (one-om2)*lfus esval = min(fpvsl(Tl1_2), pval) esval2 = min(fpvsi(Tl1_2), pval) - qs2 = om2 * eps * esval / (pval-0.378d0*esval) & - + (one-om2) * epss * esval2 / (pval-0.378d0*esval2) + qs2 = om2 * eps * esval / (pval-0.378_r8*esval) & + + (one-om2) * epss * esval2 / (pval-0.378_r8*esval2) ENDIF ! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 @@ -1663,14 +1664,14 @@ subroutine assumed_pdf() ! Update ncpl and ncpi Moorthi 12/12/2018 if (ntlnc > 0) then ! liquid and ice number concentrations predicted if (ncpl(i,k) > nmin) then - ncpl(i,k) = diag_ql/max(qc(i,k),1.0d-10)*ncpl(i,k) + ncpl(i,k) = diag_ql/max(qc(i,k),1.0e-10_r8)*ncpl(i,k) else - ncpl(i,k) = max(diag_ql/(fourb3*pi*RL_cub*997.0d0), nmin) + ncpl(i,k) = max(diag_ql/(fourb3*pi*RL_cub*997.0_r8), nmin) endif if (ncpi(i,k) > nmin) then - ncpi(i,k) = diag_qi/max(qi(i,k),1.0d-10)*ncpi(i,k) + ncpi(i,k) = diag_qi/max(qi(i,k),1.0e-10_r8)*ncpi(i,k) else - ncpi(i,k) = max(diag_qi/(fourb3*pi*RI_cub*500.0d0), nmin) + ncpi(i,k) = max(diag_qi/(fourb3*pi*RI_cub*500.0_r8), nmin) endif endif diff --git a/physics/get_prs_fv3.F90 b/physics/get_prs_fv3.F90 index dd5871896..352a61895 100644 --- a/physics/get_prs_fv3.F90 +++ b/physics/get_prs_fv3.F90 @@ -8,7 +8,7 @@ module get_prs_fv3 !--- local variables 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 contains @@ -50,7 +50,7 @@ subroutine get_prs_fv3_run(ix, levs, phii, prsi, tgrs, qgrs1, del, del_gz, errms do i=1,ix del(i,k) = prsi(i,k) - prsi(i,k+1) del_gz(i,k) = (phii(i,k+1) - phii(i,k)) / & - (tgrs(i,k)*(1.+con_fvirt*max(zero,qgrs1(i,k)))) + (tgrs(i,k)*(one + con_fvirt*max(zero,qgrs1(i,k)))) enddo enddo @@ -78,6 +78,7 @@ module get_phi_fv3 !--- local variables 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 contains @@ -118,7 +119,7 @@ subroutine get_phi_fv3_run(ix, levs, gt0, gq01, del_gz, phii, phil, errmsg, errf do k=1,levs do i=1,ix del_gz(i,k) = del_gz(i,k)*gt0(i,k) * & - & (1.+con_fvirt*max(zero,gq01(i,k))) + & (one + con_fvirt*max(zero,gq01(i,k))) phii(i,k+1) = phii(i,k) + del_gz(i,k) phil(i,k) = half*(phii(i,k) + phii(i,k+1)) enddo diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index ba7963e7d..aa2e70549 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -175,13 +175,14 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & !------------------------------------ ! input ! real, parameter :: r_air = 3.47d-3 - real, parameter :: one=1.0_kind_phys, oneb3=one/3.0_kind_phys, onebcp=one/cp, & - zero=0.0_kind_phys, half=0.5_kind_phys, onebg=one/grav, & - & kapa=rgas*onebcp, cpbg=cp/grav, & - & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp, & - & qsmall=1.0e-14_kind_phys, rainmin = 1.0e-13_kind_phys, & - & fourb3=4.0_kind_phys/3.0_kind_phys, RL_cub=1.0e-15_kind_phys, & - & nmin=1.0_kind_phys + integer, parameter :: r8 = kind_phys + real, parameter :: one=1.0_r8, oneb3=one/3.0_r8, onebcp=one/cp, & + zero=0.0_r8, half=0.5_r8, onebg=one/grav, & + & kapa=rgas*onebcp, cpbg=cp/grav, & + & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp, & + & qsmall=1.0e-14_r8, rainmin = 1.0e-13_r8, & + & fourb3=4.0_r8/3.0_r8, RL_cub=1.0e-15_r8, & + & nmin=1.0_r8 integer, parameter :: ncolmicro = 1 integer,intent(in) :: im, ix,lm, kdt, fprcp, pdfflag, iccn @@ -355,27 +356,27 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! real (kind=kind_phys), parameter :: disp_liu=2., ui_scale=1.0 & ! &, dcrit=20.0d-6 & - real (kind=kind_phys), parameter :: disp_liu=1.0_kind_phys & - &, ui_scale=1.0_kind_phys & - &, dcrit=1.0e-6_kind_phys & + real (kind=kind_phys), parameter :: disp_liu=1.0_r8 & + &, ui_scale=1.0_r8 & + &, dcrit=1.0e-6_r8 & ! &, ts_autice=1800.0 & ! &, ts_autice=3600.0 & !time scale - &, ninstr8 = 0.1e6_kind_phys & - &, ncnstr8 = 100.0e6_kind_phys + &, ninstr8 = 0.1e6_r8 & + &, ncnstr8 = 100.0e6_r8 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_kind_phys ! normalized pressure at sedimentation start + real(kind=kind_phys), parameter :: sig_sed_strt=0.05_r8 ! 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_kind_phys, fsoot_drop=0.1_kind_phys & - &, sigma_nuc_r8=0.28_kind_phys,SCLMFDFR=0.03_kind_phys + real(kind=kind_phys), parameter ::fdust_drop=1.0_r8, fsoot_drop=0.1_r8 & + &, sigma_nuc_r8=0.28_r8,SCLMFDFR=0.03_r8 ! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1 type (AerProps), dimension (IM,LM) :: AeroProps @@ -390,22 +391,22 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & !================== Start Stratiform cloud processes========================================== !set up initial values - data USE_AV_V/1./, BKGTAU/0.015/, LCCIRRUS/500./, NPRE_FRAC/1./, & - & TMAXLL/296./, fracover/1./, LTS_LOW/12./, LTS_UP/24./, & - & MIN_EXP/0.5/ - - data cloudparams/ & - & 10.0, 4.0 , 4.0 , 1.0 , 2.e-3, 8.e-4, 2.0 , 1.0 , -1.0 & - &, 0.0 , 1.3 , 1.0e-9, 3.3e-4, 20.0 , 4.8 , 4.8 , 230.0 , 1.0 & - &, 1.0 , 230.0, 14400., 50.0 , 0.01 , 0.1 , 200.0, 0.0 , 0.0 & - &, 0.5 , 0.5 , 2000.0, 0.8 , 0.5 , -40.0, 1.0 , 4.0 , 0.0 & - &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 900.0& -! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 880.0& -! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 980.0& - &, 1.0 , 1.0 , 1.0 , 0.0 , 0.0 , 1.e-5, 2.e-5, 2.1e-5, 4.e-5& -! &, 3e-5, 0.1 , 4.0 , 250./ ! Annings version - &, 3e-5, 0.1 , 4.0 , 150./ ! Annings version -! &, 3e-5, 0.1 , 1.0 , 150./ + data USE_AV_V/1.0_r8/, BKGTAU/0.015_r8/, LCCIRRUS/500.0_r8/, NPRE_FRAC/1.0_r8/, & + & TMAXLL/296.0_r8/, fracover/1.0_r8/, LTS_LOW/12.0_r8/, LTS_UP/24.0_r8/, & + & MIN_EXP/0.5_r8/ + + data cloudparams/ & + & 10.0_r8, 4.0_r8 , 4.0_r8 , 1.0_r8 , 2.e-3_r8, 8.e-4_r8, 2.0_r8 , 1.0_r8 , -1.0_r8 & + &, 0.0_r8 , 1.3_r8 , 1.0e-9_r8, 3.3e-4_r8, 20.0_r8 , 4.8_r8 , 4.8_r8 , 230.0_r8 , 1.0_r8 & + &, 1.0_r8 , 230.0_r8, 14400._r8, 50.0_r8 , 0.01_r8 , 0.1_r8 , 200.0_r8, 0.0_r8 , 0.0_r8 & + &, 0.5_r8 , 0.5_r8 , 2000.0_r8, 0.8_r8 , 0.5_r8 , -40.0_r8, 1.0_r8 , 4.0_r8 , 0.0_r8 & + &, 0.0_r8 , 0.0_r8 , 1.0e-3_r8, 8.0e-4_r8, 1.0_r8 , 0.95_r8 , 1.0_r8 , 0.0_r8 , 900.0_r8& +! &, 0.0_r8 , 0.0_r8 , 1.0e-3_r8, 8.0e-4_r8, 1.0_r8 , 0.95_r8 , 1.0_r8 , 0.0_r8 , 880.0_r8& +! &, 0.0_r8 , 0.0_r8 , 1.0e-3_r8, 8.0e-4_r8, 1.0_r8 , 0.95_r8 , 1.0_r8 , 0.0_r8 , 980.0_r8& + &, 1.0_r8 , 1.0_r8 , 1.0_r8 , 0.0_r8 , 0.0_r8 , 1.e-5_r8, 2.e-5_r8, 2.1e-5_r8, 4.e-5_r8& +! &, 3e-5_r8, 0.1_r8 , 4.0_r8 , 250.0_r8/ ! Annings version + &, 3e-5_r8, 0.1_r8 , 4.0_r8 , 150.0_r8/ ! Annings version +! &, 3e-5_r8, 0.1_r8 , 1.0_r8 , 150.0_r8/ ! Initialize CCPP error handling variables errmsg = '' @@ -441,7 +442,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & 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),zero) - PLO(i,k) = prsl_i(i,ll)*0.01_kind_phys + PLO(i,k) = prsl_i(i,ll)*0.01_r8 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) @@ -456,7 +457,7 @@ subroutine m_micro_run( 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.01_kind_phys ! interface pressure in hPa + PLE(i,k) = prsi_i(i,ll) * 0.01_r8 ! interface pressure in hPa zet(i,k+1) = phii(i,ll) * onebg END DO END DO @@ -501,7 +502,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & 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),zero) - PLO(i,k) = prsl_i(i,k)*0.01_kind_phys + PLO(i,k) = prsl_i(i,k)*0.01_r8 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) @@ -515,7 +516,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & END DO DO K=0, LM DO I = 1,IM - PLE(i,k) = prsi_i(i,k) * 0.01_kind_phys ! interface pressure in hPa + PLE(i,k) = prsi_i(i,k) * 0.01_r8 ! interface pressure in hPa zet(i,k+1) = phii(i,k) * onebg END DO END DO @@ -554,17 +555,17 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if (rnw(i,k) <= qc_min(1)) then 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_kind_phys), nmin) + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_r8), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_r8), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_r8), nmin) endif enddo @@ -578,8 +579,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & DO I=1, IM DO K = LM-2, 10, -1 - If ((CNV_DQLDT(I,K) <= 1.0e-9_kind_phys) .and. & - & (CNV_DQLDT(I,K+1) > 1.0e-9_kind_phys)) then + If ((CNV_DQLDT(I,K) <= 1.0e-9_r8) .and. & + & (CNV_DQLDT(I,K+1) > 1.0e-9_r8)) then KCT(I) = K+1 exit end if @@ -659,7 +660,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do l=lm-1,1,-1 do i=1,im tx1 = half * (temp(i,l+1) + temp(i,l)) - kh(i,l) = 3.55e-7_kind_phys*tx1**2.5_kind_phys*(rgas*0.01_kind_phys) / ple(i,l) !kh molecule diff only needing refinement + kh(i,l) = 3.55e-7_r8*tx1**2.5_r8*(rgas*0.01_r8) / ple(i,l) !kh molecule diff only needing refinement enddo end do do i=1,im @@ -668,8 +669,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & enddo do L=LM,1,-1 do i=1,im - blk_l(i,l) = one / ( one/max(0.15_kind_phys*ZPBL(i),0.4_kind_phys*zlo(i,lm-1))& - & + one/(zlo(i,l)*0.4_kind_phys) ) + blk_l(i,l) = one / ( one/max(0.15_r8*ZPBL(i),0.4_r8*zlo(i,lm-1))& + & + one/(zlo(i,l)*0.4_r8) ) SC_ICE(i,l) = one NCPL(i,l) = MAX( NCPL(i,l), zero) @@ -688,8 +689,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do l=1,lm - rhdfdar8(l) = 1.e-8_kind_phys - rhu00r8(l) = 0.95_kind_phys + rhdfdar8(l) = 1.e-8_r8 + rhu00r8(l) = 0.95_r8 ttendr8(l) = zero qtendr8(l) = zero @@ -699,7 +700,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & enddo do k=1,10 do l=1,lm - rndstr8(l,k) = 2.0d-7 + rndstr8(l,k) = 2.0e-7_r8 enddo enddo @@ -734,8 +735,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if ( iccn == 2) then AERMASSMIX(:,:,1:ntrcaer) = aerfld_i(:,:,1:ntrcaer) else - AERMASSMIX(:,:,1:5) = 1.0e-6_kind_phys - AERMASSMIX(:,:,6:15) = 2.0e-14_kind_phys + AERMASSMIX(:,:,1:5) = 1.0e-6_r8 + AERMASSMIX(:,:,6:15) = 2.0e-14_r8 end if !> - Call aerconversion1() call AerConversion1 (AERMASSMIX, AeroProps) @@ -754,23 +755,23 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & kcldtopcvn = KCT(I) tausurf_gw = min(half*SQRT(TAUOROX(I)*TAUOROX(I) & - & + TAUOROY(I)*TAUOROY(I)), 10.0_kind_phys) + & + TAUOROY(I)*TAUOROY(I)), 10.0_r8) do k=1,lm uwind_gw(k) = min(half*SQRT( U1(I,k)*U1(I,k) & - & + V1(I,k)*V1(I,k)), 50.0_kind_phys) + & + V1(I,k)*V1(I,k)), 50.0_r8) ! 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_kind_phys*PLO(I,k) + pm_gw(k) = 100.0_r8*PLO(I,k) tm_gw(k) = TEMP(I,k) nm_gw(k) = zero rho_gw(k) = pm_gw(k) /(RGAS*tm_gw(k)) ter8(k) = TEMP(I,k) - plevr8(k) = 100.0_kind_phys*PLO(I,k) + plevr8(k) = 100.0_r8*PLO(I,k) ndropr8(k) = NCPL(I,k) qir8(k) = QILS(I,k) + QICN(I,k) qcr8(k) = QLLS(I,k) + QLCN(I,k) @@ -781,27 +782,27 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & npre8(k) = zero - if (RAD_CF(I,k) > 0.01_kind_phys .and. qir8(k) > zero) then + if (RAD_CF(I,k) > 0.01_r8 .and. qir8(k) > zero) then npre8(k) = NPRE_FRAC*NCPI(I,k) else npre8(k) = zero endif omegr8(k) = OMEGA(I,k) - lc_turb(k) = max(blk_l(I,k), 50.0_kind_phys) + lc_turb(k) = max(blk_l(I,k), 50.0_r8) ! rad_cooling(k) = RADheat(I,k) if (npre8(k) > zero .and. qir8(k) > zero) then - dpre8(k) = ( qir8(k)/(6.0_kind_phys*npre8(k)*900.0_kind_phys*PI))**(one/3.0_kind_phys) + dpre8(k) = ( qir8(k)/(6.0_r8*npre8(k)*900.0_r8*PI))**(one/3.0_r8) else - dpre8(k) = 1.0e-9_kind_phys + dpre8(k) = 1.0e-9_r8 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_kind_phys*PLE(I,k) + pi_gw(k) = 100.0_r8*PLE(I,k) rhoi_gw(k) = zero ni_gw(k) = zero ti_gw(k) = zero @@ -817,13 +818,13 @@ subroutine m_micro_run( 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_kind_phys) + nm_gw(k) = max(nm_gw(k), 0.005_r8) h_gw(k) = k_gw*rho_gw(k)*uwind_gw(k)*nm_gw(k) if (h_gw(K) > zero) then - h_gw(K) = sqrt(2.0_kind_phys*tausurf_gw/h_gw(K)) + h_gw(K) = sqrt(2.0_r8*tausurf_gw/h_gw(K)) end if - wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133_kind_phys + wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133_r8 wparc_cgw(k) = zero end do @@ -840,14 +841,14 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do k=1,kcldtopcvn c2_gw = (nm_gw(k) + Nct) / Nct - wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56_kind_phys* & - & 1.806_kind_phys*c2_gw*c2_gw)*Wct*0.133_kind_phys + wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56_r8* & + & 1.806_r8*c2_gw*c2_gw)*Wct*0.133_r8 enddo end if do k=1,lm - dummyW(k) = 0.133_kind_phys*k_gw*uwind_gw(k)/nm_gw(k) + dummyW(k) = 0.133_r8*k_gw*uwind_gw(k)/nm_gw(k) enddo do K=1, LM-5, 1 @@ -867,17 +868,17 @@ subroutine m_micro_run( 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_kind_phys + dummyW(k) = 10.0_r8 enddo - if (FRLAND(I) < 0.1_kind_phys .and. ZPBL(I) < 800.0_kind_phys .and. & - & TEMP(I,LM) < 298.0_kind_phys .and. TEMP(I,LM) > 274.0_kind_phys) then + if (FRLAND(I) < 0.1_r8 .and. ZPBL(I) < 800.0_r8 .and. & + & TEMP(I,LM) < 298.0_r8 .and. TEMP(I,LM) > 274.0_r8) then do K = 1, LM - dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01_kind_phys, 10.0_kind_phys),-10.0_kind_phys) + dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01_r8, 10.0_r8),-10.0_r8) dummyW(k) = one / (one+exp(dummyW(k))) enddo maxkh = max(maxval(KH(I,kbmin:LM-1)*nm_gw(kbmin:LM-1)/ & - & 0.17_kind_phys), 0.3_kind_phys) + & 0.17_r8), 0.3_r8) do K = 1, LM wparc_turb(k) = (one-dummyW(k))*wparc_turb(k) & & + dummyW(k)*maxkh @@ -885,7 +886,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & end if - wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2_kind_phys) + wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2_r8) @@ -903,11 +904,11 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do K = 1, LM - if (plevr8(K) > 70.0_kind_phys) then + if (plevr8(K) > 70.0_r8) then - ccn_diag(1) = 0.001_kind_phys - ccn_diag(2) = 0.004_kind_phys - ccn_diag(3) = 0.01_kind_phys + ccn_diag(1) = 0.001_r8 + ccn_diag(2) = 0.004_r8 + ccn_diag(3) = 0.01_r8 if (K > 2 .and. K <= LM-2) then tauxr8 = (ter8(K-1) + ter8(K+1) + ter8(K)) * oneb3 @@ -944,7 +945,7 @@ subroutine m_micro_run( 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.0d-12) npccninr8(k) = zero + if (npccninr8(k) < 1.0e-12_r8) 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) @@ -958,7 +959,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & swparc(K) = zero smaxicer8(K) = zero nheticer8(K) = zero - sc_icer8(K) = 2.0_kind_phys + sc_icer8(K) = 2.0_r8 ! sc_icer8(K) = 1.0d0 naair8(K) = zero npccninr8(K) = zero @@ -975,9 +976,9 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! SMAXL(I,k) = smaxliq(k) * 100.0 ! SMAXI(I,k) = smaxicer8(k) * 100.0 - NHET_NUC(I,k) = nheticer8(k) * 1.0e-6_kind_phys - NLIM_NUC(I,k) = nlimicer8(k) * 1.0e-6_kind_phys - SC_ICE(I,k) = min(max(sc_icer8(k),one),2.0_kind_phys) + NHET_NUC(I,k) = nheticer8(k) * 1.0e-6_r8 + NLIM_NUC(I,k) = nlimicer8(k) * 1.0e-6_r8 + SC_ICE(I,k) = min(max(sc_icer8(k),one),2.0_r8) ! 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) @@ -987,13 +988,13 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if (iccn == 0) then 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_kind_phys) + SC_ICE(i,k) = max(SC_ICE(I,k), 1.5_r8) 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_kind_phys) + tx1 = max(SC_ICE(I,k), 1.5_r8) SC_ICE(i,k) = ((tice-temp(i,k))*tx1 + (temp(i,k)-t_ice_all)*rhc(i,k)) & * t_ice_denom endif @@ -1004,12 +1005,12 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & endif 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.0e-6_kind_phys - NHET_DHF(I,k) = nhet_dhfr8(k) * 1.0e-6_kind_phys - DUST_IMM(I,k) = max(dust_immr8(k), zero)*1.0e-6_kind_phys - DUST_DEP(I,k) = max(dust_depr8(k), zero)*1.0e-6_kind_phys - DUST_DHF(I,k) = max(dust_dhfr8(k), zero)*1.0e-6_kind_phys - WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8_kind_phys + NHET_DEP(I,k) = nhet_depr8(k) * 1.0e-6_r8 + NHET_DHF(I,k) = nhet_dhfr8(k) * 1.0e-6_r8 + DUST_IMM(I,k) = max(dust_immr8(k), zero)*1.0e-6_r8 + DUST_DEP(I,k) = max(dust_depr8(k), zero)*1.0e-6_r8 + DUST_DHF(I,k) = max(dust_dhfr8(k), zero)*1.0e-6_r8 + WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8_r8 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) @@ -1122,7 +1123,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do k=1,lm do i=1,im - if (CNV_MFD(i,k) > 1.0e-6_kind_phys) then + if (CNV_MFD(i,k) > 1.0e-6_r8) 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 @@ -1231,7 +1232,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & do l=1,10 do k=1,lm naconr8(k,l) = zero - rndstr8(k,l) = 2.0e-7_kind_phys + rndstr8(k,l) = 2.0e-7_r8 enddo enddo do k=1,lm @@ -1242,7 +1243,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) tx1 = MIN(CLLS(I,k) + CLCN(I,k), one) if (tx1 > zero) then - cldfr8(k) = min(max(tx1, 0.00001_kind_phys), one) + cldfr8(k) = min(max(tx1, 0.00001_r8), one) else cldfr8(k) = zero endif @@ -1278,7 +1279,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & naair8(k) = INC_NUC(I,k) npccninr8(k) = CDNC_NUC(I,k) - if (cldfr8(k) >= 0.001_kind_phys) then + if (cldfr8(k) >= 0.001_r8) then nimmr8(k) = min(DNHET_IMM(I,k),ncr8(k)/(cldfr8(k)*DT_MOIST)) else nimmr8(k) = zero @@ -1306,11 +1307,11 @@ subroutine m_micro_run( 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_kind_phys + pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0_r8 rpdelr8(k) = one / pdelr8(k) - plevr8(k) = 100.0_kind_phys * PLO(I,k) + plevr8(k) = 100.0_r8 * PLO(I,k) zmr8(k) = ZLO(I,k) - ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.0e-10_kind_phys) + ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.0e-10_r8) omegr8(k) = WSUB(I,k) ! alphar8(k) = max(alpht_x(i,k)/maxval(alpht_x(i,:))*8.,0.5) ! alphar8(k) = qcvar2 @@ -1318,7 +1319,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & END DO do k=1,lm+1 - pintr8(k) = PLE(I,k-1) * 100.0_kind_phys + pintr8(k) = PLE(I,k-1) * 100.0_r8 kkvhr8(k) = KH(I,k-1) END DO @@ -1403,8 +1404,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! if (lprint) write(0,*)' prectr8=',prectr8(1), & ! & ' precir8=',precir8(1) - LS_PRC2(I) = max(1000.0_kind_phys*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0_kind_phys*precir8(1), zero) + LS_PRC2(I) = max(1000.0_r8*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_r8*precir8(1), zero) do k=1,lm @@ -1422,10 +1423,10 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & NCPR(I,k) = nrr8(k) NCPS(I,k) = nsr8(k) - CLDREFFL(I,k) = min(max(effcr8(k), 10.0_kind_phys), 150.0_kind_phys) - CLDREFFI(I,k) = min(max(effir8(k), 20.0_kind_phys), 150.0_kind_phys) - CLDREFFR(I,k) = max(droutr8(k)*0.5_kind_phys*1.0e6_kind_phys, 150.0_kind_phys) - CLDREFFS(I,k) = max(0.192_kind_phys*dsoutr8(k)*0.5_kind_phys*1.0e6_kind_phys, 250.0_kind_phys) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_r8), 150.0_r8) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_r8), 150.0_r8) + CLDREFFR(I,k) = max(droutr8(k)*0.5_r8*1.0e6_r8, 150.0_r8) + CLDREFFS(I,k) = max(0.192_r8*dsoutr8(k)*0.5_r8*1.0e6_r8, 250.0_r8) enddo ! K loop @@ -1507,8 +1508,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, & & lev_sed_strt) ! - LS_PRC2(I) = max(1000.0_kind_phys*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0_kind_phys*precir8(1), zero) + LS_PRC2(I) = max(1000.0_r8*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_r8*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 @@ -1522,10 +1523,10 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & 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.0_kind_phys), 150.0_kind_phys) - CLDREFFI(I,k) = min(max(effir8(k), 20.0_kind_phys), 150.0_kind_phys) - CLDREFFR(I,k) = max(reff_rain(k), 150.0_kind_phys) - CLDREFFS(I,k) = max(reff_snow(k), 250.0_kind_phys) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_r8), 150.0_r8) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_r8), 150.0_r8) + CLDREFFR(I,k) = max(reff_rain(k), 150.0_r8) + CLDREFFS(I,k) = max(reff_snow(k), 250.0_r8) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1536,10 +1537,10 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & LS_PRC2(I) = zero LS_SNR(I) = zero do k=1,lm - CLDREFFL(I,k) = 10.0_kind_phys - CLDREFFI(I,k) = 50.0_kind_phys - CLDREFFR(I,k) = 1000.0_kind_phys - CLDREFFS(I,k) = 250.0_kind_phys + CLDREFFL(I,k) = 10.0_r8 + CLDREFFI(I,k) = 50.0_r8 + CLDREFFR(I,k) = 1000.0_r8 + CLDREFFS(I,k) = 250.0_r8 enddo ! K loop endif ! @@ -1644,8 +1645,8 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, & & lev_sed_strt) - LS_PRC2(I) = max(1000.0_kind_phys*(prectr8(1)-precir8(1)), zero) - LS_SNR(I) = max(1000.0_kind_phys*precir8(1), zero) + LS_PRC2(I) = max(1000.0_r8*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_r8*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 @@ -1661,11 +1662,11 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & 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.0_kind_phys), 150.0_kind_phys) - CLDREFFI(I,k) = min(max(effir8(k), 20.0_kind_phys), 150.0_kind_phys) - CLDREFFR(I,k) = max(reff_rain(k),150.0_kind_phys) - CLDREFFS(I,k) = max(reff_snow(k),250.0_kind_phys) - CLDREFFG(I,k) = max(reff_grau(k),250.0_kind_phys) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_r8), 150.0_r8) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_r8), 150.0_r8) + CLDREFFR(I,k) = max(reff_rain(k), 150.0_r8) + CLDREFFS(I,k) = max(reff_snow(k), 250.0_r8) + CLDREFFG(I,k) = max(reff_grau(k), 250.0_r8) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1676,11 +1677,11 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & LS_PRC2(I) = zero LS_SNR(I) = zero do k=1,lm - CLDREFFL(I,k) = 10.0_kind_phys - CLDREFFI(I,k) = 50.0_kind_phys - CLDREFFR(I,k) = 1000.0_kind_phys - CLDREFFS(I,k) = 250.0_kind_phys - CLDREFFG(I,k) = 250.0_kind_phys + CLDREFFL(I,k) = 10.0_r8 + CLDREFFI(I,k) = 50.0_r8 + CLDREFFR(I,k) = 1000.0_r8 + CLDREFFS(I,k) = 250.0_r8 + CLDREFFG(I,k) = 250.0_r8 enddo ! K loop endif endif @@ -1708,17 +1709,17 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if (rnw(i,k) <= qc_min(1)) then 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_kind_phys), nmin) + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_r8), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_r8), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_r8), nmin) endif enddo enddo @@ -1748,17 +1749,17 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & if (rnw(i,k) <= qc_min(1)) then 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_kind_phys), nmin) + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_r8), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_r8), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kind_phys), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_r8), nmin) endif enddo enddo @@ -1850,7 +1851,7 @@ subroutine m_micro_run( 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_kind_phys + rn_o(i) = tx1 * dt_i * 0.001_r8 if (rn_o(i) < rainmin) then sr_o(i) = zero @@ -1903,6 +1904,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & use physcons, grav => con_g, cp => con_cp, rgas => con_rd, & fv => con_fvirt implicit none + integer, parameter :: r8 = kind_phys !----------------------------------------------------------------------- ! Compute profiles of background state quantities for the multiple ! gravity wave drag parameterization. @@ -1926,7 +1928,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.0d0/cp, n2min=1.0d-8 + oneocp=1.0_r8/cp, n2min=1.0e-8_r8 !---------------------------Local storage------------------------------- integer :: ix,kx @@ -1942,15 +1944,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.0d0+fv*sph(ix,kx+1)))) + rhoi(ix,kx) = pi(ix,kx) / (r*(ti(ix,kx)*(1.0_r8+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.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)))) + ti(ix,kx) = 0.5_r8 * (t(ix,kx) + t(ix,kx+1)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0_r8+0.5_r8*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)) @@ -1962,7 +1964,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.0d0+fv*sph(ix,kx))) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0_r8+fv*sph(ix,kx))) ni(ix,kx) = ni(ix,kx-1) end do @@ -1971,7 +1973,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.5d0 * (ni(ix,kx-1) + ni(ix,kx)) + nm(ix,kx) = 0.5_r8 * (ni(ix,kx-1) + ni(ix,kx)) end do end do diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 8648e631b..bbd03a186 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -182,14 +182,14 @@ subroutine sfc_sice_run & ! --- locals: real (kind=kind_phys), dimension(im) :: ffw, evapi, evapw, & - & sneti, snetw, hfd, hfi, & + & sneti, hfd, hfi, & ! & hflxi, hflxw, sneti, snetw, qssi, qssw, hfd, hfi, hfw, & & focn, snof, rch, rho, & & snowd, theta1 real (kind=kind_phys) :: t12, t14, tem, stsice(im,kmi) &, hflxi, hflxw, q0, qs1, qssi, qssw - real (kind=kind_phys) :: cpinv, hvapi, elocp + real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw integer :: i, k integer, dimension(im) :: islmsk_local @@ -309,11 +309,11 @@ subroutine sfc_sice_run & evapw(i) = elocp * rch(i) * (qssw - q0) ! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) - snetw(i) = sfcdsw(i) * (one - albfw) - snetw(i) = min(3.0_kind_phys*sfcnsw(i) & - & / (one+2.0_kind_phys*ffw(i)), snetw(i)) + snetw = sfcdsw(i) * (one - albfw) + snetw = min(3.0_kind_phys*sfcnsw(i) & + & / (one+2.0_kind_phys*ffw(i)), snetw) !> - Calculate net solar incoming at top \a sneti. - sneti(i) = (sfcnsw(i) - ffw(i)*snetw(i)) / fice(i) + sneti(i) = (sfcnsw(i) - ffw(i)*snetw) / fice(i) t12 = tice(i) * tice(i) t14 = t12 * t12 @@ -337,7 +337,7 @@ subroutine sfc_sice_run & ! --- ... hfw = net heat flux @ water surface (within ice) ! hfw(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapw(i) & -! & + rch(i)*(tgice - theta1(i)) - snetw(i) +! & + rch(i)*(tgice - theta1(i)) - snetw !> - Assigin heat flux from ocean \a focn and snowfall rate as constants, which !! should be from ocean model and other physics. From f245b7a614906d6bf4ec5822335362618f3b7ac4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 2 May 2020 23:38:19 +0000 Subject: [PATCH 15/30] some updates for several routines --- physics/GFS_rrtmg_pre.F90 | 2 +- physics/GFS_surface_composites.F90 | 14 ++-- physics/GFS_surface_generic.F90 | 4 - physics/moninshoc.f | 62 +++++++------- physics/tridi.f | 28 ++++--- physics/ugwp_driver_v0.F | 129 +++++++++++++++-------------- 6 files changed, 125 insertions(+), 114 deletions(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 01649793b..e2dad0f4d 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -473,7 +473,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input !check print *,' in grrad : calling setaer ' call setaer (plvl, plyr, prslk1, tvly, rhly, Sfcprop%slmsk, & ! --- inputs - tracer1, Tbd%aer_nm, & + tracer1, Tbd%aer_nm, & Grid%xlon, Grid%xlat, IM, LMK, LMP, & Model%lsswr,Model%lslwr, & faersw,faerlw,aerodp) ! --- outputs diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index ae9724844..86eb28419 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -80,7 +80,7 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl else cice(i) = zero flag_cice(i) = .false. - islmsk = 0 + islmsk(i) = 0 endif else if (cice(i) >= min_lakeice) then @@ -91,10 +91,10 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl endif endif if (cice(i) < one ) then - wet(i)=.true. ! some open ocean/lake water exists - if (.not. cplflx .or. oceanfrac(i) == zero) & - tsfco(i) = max(tsfco(i), tisfc(i), tgice) - end if + wet(i) = .true. ! some open ocean/lake water exists + if ((.not. cplflx .or. oceanfrac(i) == zero) .and. icy(i)) & + tsfco(i) = max(tisfc(i), tgice) + endif else cice(i) = zero endif @@ -127,8 +127,8 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl endif endif if (cice(i) < one) then - wet(i)=.true. ! some open ocean/lake water exists - if (.not. cplflx) tsfco(i) = max(tsfco(i), tisfc(i), tgice) + wet(i) = .true. ! some open ocean/lake water exists + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) endif endif enddo diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 116b3e29f..ddcb8d72e 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -341,13 +341,9 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt snowca(i) = snowca(i) + snowc(i) * dtf snohfa(i) = snohfa(i) + snohf(i) * dtf ep(i) = ep(i) + ep1d(i) * dtf - enddo - endif ! --- ... total runoff is composed of drainage into water table and ! runoff at the surface and is accumulated in unit of meters - if (lssav) then - do i=1,im runoff(i) = runoff(i) + (drain(i)+runof(i)) * dtf srunoff(i) = srunoff(i) + runof(i) * dtf enddo diff --git a/physics/moninshoc.f b/physics/moninshoc.f index 4afe19dec..14aaf1660 100644 --- a/physics/moninshoc.f +++ b/physics/moninshoc.f @@ -102,13 +102,13 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! &, dkmin=zero, dkmax=1000., xkzminv=0.3 &, prmin=0.25_r8, prmax=4.0_r8, vk=0.4_r8, & cfac=6.5_r8 - real(kind=kind_phys) :: gravi, cont, conq, conw, gocp + real(kind=kind_phys) :: gravi, cont, conq, gocp, go2 - gravi = one/grav - cont = cp/grav - conq = hvap/grav - conw = one/grav - gocp = grav/cp + gravi = one / grav + cont = cp * gravi + conq = hvap * gravi + gocp = grav / cp + go2 = grav * 0.5_r8 ! Initialize CCPP error handling variables errmsg = '' @@ -121,7 +121,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, if (ix < im) stop ! dt2 = delt - rdt = 1. / dt2 + rdt = one / dt2 km1 = km - 1 kmpbl = km / 2 ! @@ -202,13 +202,13 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo do i = 1,im theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) - thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-tx1(i)) + thvx(i,k) = theta(i,k)*(one+fv*max(q1(i,k,1),qmin)-tx1(i)) enddo enddo ! do i = 1,im sflux(i) = heat(i) + evap(i)*fv*theta(i,1) - if(.not.sfcflg(i) .or. sflux(i) <= zero) pblflg(i)=.false. + if (.not.sfcflg(i) .or. sflux(i) <= zero) pblflg(i)=.false. beta(i) = dt2 / (zi(i,2)-zi(i,1)) enddo ! @@ -219,7 +219,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, flg(i) = .false. rbup(i) = rbsoil(i) ! - if(pblflg(i)) then + if (pblflg(i)) then thermal(i) = thvx(i,1) crb(i) = crbcon else @@ -233,9 +233,9 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo do k = 1, kmpbl do i = 1, im - if(.not.flg(i)) then + 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 @@ -246,7 +246,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, do i = 1,im if(kpbl(i) > 1) then k = kpbl(i) - if(rbdn(i) >= crb(i)) then + if (rbdn(i) >= crb(i)) then rbint = zero elseif(rbup(i) <= crb(i)) then rbint = one @@ -265,13 +265,13 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! do i=1,im zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) - if(sfcflg(i)) then + if (sfcflg(i)) then zol(i) = min(zol(i),-zfmin) else zol(i) = max(zol(i),zfmin) endif zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) - if(sfcflg(i)) then + if (sfcflg(i)) then ! phim(i) = (1.-aphi16*zol1)**(-1./4.) ! phih(i) = (1.-aphi16*zol1)**(-1./2.) tem = one / max(one - aphi16*zol1, 1.0e-8_r8) @@ -294,7 +294,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo do k = 2, kmpbl do i = 1, im - if(.not.flg(i)) then + if (.not.flg(i)) then rbdn(i) = rbup(i) 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) @@ -348,8 +348,7 @@ subroutine moninshoc_run (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_r8*grav)*(thvx(i,kp1)-thvx(i,k))*rdz - & / (t1(i,k)+t1(i,kp1)) + bvf2 = go2*(thvx(i,kp1)-thvx(i,k))*rdz / (t1(i,k)+t1(i,kp1)) ri = max(bvf2/tem,rimin) if(ri < zero) then ! unstable regime prnum(i,kp1) = one @@ -427,7 +426,7 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo endif ! -! solve tridiagonal problem for heat and moisture +! solve tridiagonal problem for heat, moisture and tracers ! call tridin(im,km,ntloc,al,ad,au,a1,a2,au,a1,a2) @@ -435,14 +434,18 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! recover tendencies of heat and moisture ! do k = 1,km - do i = 1,im - ttend = (a1(i,k)-t1(i,k)) * rdt - qtend = (a2(i,k)-q1(i,k,1)) * rdt - tau(i,k) = tau(i,k) + ttend - rtg(i,k,1) = rtg(i,k,1) + qtend - dtsfc(i) = dtsfc(i) + cont*del(i,k)*ttend - dqsfc(i) = dqsfc(i) + conq*del(i,k)*qtend - enddo + do i = 1,im + ttend = (a1(i,k)-t1(i,k)) * rdt + qtend = (a2(i,k)-q1(i,k,1)) * rdt + tau(i,k) = tau(i,k) + ttend + rtg(i,k,1) = rtg(i,k,1) + qtend + dtsfc(i) = dtsfc(i) + del(i,k)*ttend + dqsfc(i) = dqsfc(i) + del(i,k)*qtend + enddo + enddo + do i = 1,im + dtsfc(i) = dtsfc(i) * cont + dqsfc(i) = dqsfc(i) * conq enddo if(ntrac > 1) then is = 0 @@ -497,8 +500,9 @@ subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, vtend = (a2(i,k)-v1(i,k))*rdt du(i,k) = du(i,k) + utend dv(i,k) = dv(i,k) + vtend - dusfc(i) = dusfc(i) + conw*del(i,k)*utend - dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend + tem = del(i,k) * gravi + dusfc(i) = dusfc(i) + tem * utend + dvsfc(i) = dvsfc(i) + tem * vtend enddo enddo ! diff --git a/physics/tridi.f b/physics/tridi.f index bd44bcc86..c8e77403b 100644 --- a/physics/tridi.f +++ b/physics/tridi.f @@ -9,6 +9,7 @@ subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) ! use machine , only : kind_phys implicit none + integer, parameter :: one = 1.0_kind_phys integer k,n,l,i real(kind=kind_phys) fk ! @@ -16,19 +17,19 @@ subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) & au(l,n-1),a1(l,n) ! 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 @@ -48,6 +49,7 @@ subroutine tridi2(l,n,cl,cm,cu,r1,r2,au,a1,a2) cc use machine , only : kind_phys implicit none + integer, parameter :: one = 1.0_kind_phys integer k,n,l,i real(kind=kind_phys) fk cc @@ -55,21 +57,21 @@ subroutine tridi2(l,n,cl,cm,cu,r1,r2,au,a1,a2) & au(l,n-1),a1(l,n),a2(l,n) c---------------------------------------------------------------------- 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) a2(i,1) = fk*r2(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)) a2(i,k) = fk*(r2(i,k)-cl(i,k)*a2(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)) a2(i,n) = fk*(r2(i,n)-cl(i,n)*a2(i,n-1)) enddo @@ -93,6 +95,7 @@ subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) cc use machine , only : kind_phys implicit none + integer, parameter :: one = 1.0_kind_phys integer is,k,kk,n,nt,l,i real(kind=kind_phys) fk(l) cc @@ -102,7 +105,7 @@ subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) & fkk(l,2:n-1) c----------------------------------------------------------------------- do i=1,l - fk(i) = 1./cm(i,1) + fk(i) = one / cm(i,1) au(i,1) = fk(i)*cu(i,1) a1(i,1) = fk(i)*r1(i,1) enddo @@ -114,7 +117,7 @@ subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) enddo do k=2,n-1 do i=1,l - fkk(i,k) = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + fkk(i,k) = one / (cm(i,k)-cl(i,k)*au(i,k-1)) au(i,k) = fkk(i,k)*cu(i,k) a1(i,k) = fkk(i,k)*(r1(i,k)-cl(i,k)*a1(i,k-1)) enddo @@ -128,7 +131,7 @@ subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) enddo enddo do i=1,l - fk(i) = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + fk(i) = one / (cm(i,n)-cl(i,n)*au(i,n-1)) a1(i,n) = fk(i)*(r1(i,n)-cl(i,n)*a1(i,n-1)) enddo do k = 1, nt @@ -163,6 +166,7 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) !! use machine , only : kind_phys implicit none + integer, parameter :: one = 1.0_kind_phys integer is,k,kk,n,nt,l,i real(kind=kind_phys) fk(l) !! @@ -172,7 +176,7 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) & fkk(l,2:n-1) !----------------------------------------------------------------------- do i=1,l - fk(i) = 1./cm(i,1) + fk(i) = one / cm(i,1) au(i,1) = fk(i)*cu(i,1) enddo do k = 1, nt @@ -183,7 +187,7 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) enddo do k=2,n-1 do i=1,l - fkk(i,k) = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + fkk(i,k) = one / (cm(i,k)-cl(i,k)*au(i,k-1)) au(i,k) = fkk(i,k)*cu(i,k) enddo enddo @@ -196,7 +200,7 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) enddo enddo do i=1,l - fk(i) = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + fk(i) = one / (cm(i,n)-cl(i,n)*au(i,n-1)) enddo do k = 1, nt is = (k-1) * n diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index 4edd84a7a..819c995a4 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -6,8 +6,8 @@ module sso_coorde ! 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 + real(kind=kind_phys),parameter :: pgwd = 1.0_kind_phys + real(kind=kind_phys),parameter :: pgwd4 = 1.0_kind_phys end module sso_coorde ! ! @@ -37,6 +37,8 @@ subroutine cires_ugwp_driver_v0(me, master, implicit none !input + integer, parameter :: r8 = kind_phys + integer, intent(in) :: me, master integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr @@ -86,8 +88,9 @@ subroutine cires_ugwp_driver_v0(me, master, ! ! 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 - &, ompked=1.0-pked + real(kind=kind_phys), parameter :: pogw=1.0_r8, pngw=1.0_r8 + &, pked=1.0_r8, zero=0.0_r8 + &, ompked=1.0_r8-pked ! ! switches for GW-effects: pogw=1 (OGWs) pngw=1 (NGWs) pked=1 (eddy mixing) ! @@ -102,7 +105,7 @@ subroutine cires_ugwp_driver_v0(me, master, endif do i=1,im - zlwb(i) = 0. + zlwb(i) = zero enddo ! ! 1) ORO stationary GWs @@ -128,13 +131,13 @@ subroutine cires_ugwp_driver_v0(me, master, else ! calling old GFS gravity wave drag as is do k=1,levs do i=1,im - pdvdt(i,k) = 0.0 - pdudt(i,k) = 0.0 - pdtdt(i,k) = 0.0 - pkdis(i,k) = 0.0 + pdvdt(i,k) = zero + pdudt(i,k) = zero + pdtdt(i,k) = zero + pkdis(i,k) = zero enddo enddo - if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + if (cdmbgwd(1) > zero.or. cdmbgwd(2) > zero)_r8 then call gwdps(im, im, im, levs, Pdvdt, Pdudt, Pdtdt & &, ugrs, vgrs, tgrs, qgrs & &, kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt& @@ -144,11 +147,11 @@ subroutine cires_ugwp_driver_v0(me, master, &, nmtvr, cdmbgwd(1:2), me, lprnt, ipr, rdxzb) endif - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero + du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero endif ! - if (cdmbgwd(3) > 0.0) then + if (cdmbgwd(3) > zero) then ! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing ! ---------------------------------------------- !-------- @@ -158,11 +161,11 @@ subroutine cires_ugwp_driver_v0(me, master, ! call slat_geos5(im, xlatd, tau_ngw) ! - if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then - if (cdmbgwd(4) > 0.0) then + if (abs(1.0_r8-cdmbgwd(3)) > 1.0e-6_r8) then + if (cdmbgwd(4) > zero) then do i=1,im - turb_fac(i) = 0.0 - tem(i) = 0.0 + turb_fac(i) = zero + tem(i) = zero enddo if (ntke > 0) then do k=1,(levs+levs)/3 @@ -178,7 +181,7 @@ subroutine cires_ugwp_driver_v0(me, master, rfac = 86400000 / dtp do i=1,im tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) - tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) + tau_ngw(i) = tau_ngw(i) * max(0.1_r8, min(5.0_r8, tx1)) enddo endif do i=1,im @@ -217,10 +220,10 @@ subroutine cires_ugwp_driver_v0(me, master, enddo endif - if (pogw == 0.0) then + if (pogw == zero) then ! zmtb = 0.; zogw =0. - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero + du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero endif return @@ -234,7 +237,7 @@ subroutine cires_ugwp_driver_v0(me, master, !------------------------------------------------------------------------------ do k=1,levs do i=1,im - ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 + ed_dudt(i,k) = zero ; ed_dvdt(i,k) = zero ; ed_dtdt(i,k) = zero enddo enddo @@ -300,6 +303,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, use sso_coorde, only : pgwd, pgwd4 !---------------------------------------- implicit none + integer, parameter :: r8 = kind_phys character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' integer, intent(in) :: im, km, imx, kdt integer, intent(in) :: me, master @@ -345,9 +349,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! cleff = 2.5*0.5e-5 * sqrt(192./768.) => Lh_eff = 1004. km ! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective !--------------------------------------------------------------------- - real(kind=kind_phys) :: gammin = 0.00999999 - real(kind=kind_phys), parameter :: nhilmax = 25. - real(kind=kind_phys), parameter :: sso_min = 3000. + real(kind=kind_phys) :: gammin = 0.00999999_r8 + real(kind=kind_phys), parameter :: nhilmax = 25.0_r8 + real(kind=kind_phys), parameter :: sso_min = 3000.0_r8 logical, parameter :: do_adjoro = .true. ! real(kind=kind_phys) :: shilmin, sgrmax, sgrmin @@ -421,7 +425,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) dxres = pi2*arad/float(IMX) - hdxres = 0.5*dxres + hdxres = 0.5_r8*dxres ! shilmin = sgrmin/nhilmax ! not used - Moorthi ! gammin = min(sso_min/dsmax, 1.) ! Moorthi - with this results are not reproducible @@ -1272,6 +1276,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! nov 2017 nh/rotational gw-modes for nh-fv3gfs ! --------------------------------------------------------------------------------- ! + use machine, only : kind_phys use ugwp_common , only : rgrav, grav, cpd, rd, rv &, omega2, rcpd2, pi, pi2, fv @@ -1290,6 +1295,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, implicit none !23456 + integer, parameter :: r8 = kind_phys integer, intent(in) :: klev ! vertical level integer, intent(in) :: klon ! horiz tiles @@ -1316,8 +1322,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, 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, parameter :: minvel = 0.5_r8 ! + real, parameter :: epsln = 1.0e-12_r8 ! + real, parameter :: zero = 0.0_r8, one = 1.0_r8, half = 0.5_r8 !vay-2018 @@ -1379,7 +1386,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! real :: rcpd, grav2cpd real, parameter :: rcpdl = cpd/grav ! 1/[g/cp] == cp/g &, grav2cpd = grav/rcpdl ! g*(g/cp)= g^2/cp - &, cpdi = 1.0d0/cpd + &, cpdi = one/cpd real :: expdis, fdis ! real :: fmode, expdis, fdis @@ -1391,10 +1398,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! do k=1,klev do j=1,klon - pdvdt(j,k) = 0.0 - pdudt(j,k) = 0.0 - pdtdt(j,k) = 0.0 - dked(j,k) = 0.0 + pdvdt(j,k) = zero + pdudt(j,k) = zero + pdtdt(j,k) = zero + dked(j,k) = zero phil(j,k) = philg(j,k) * rgrav enddo enddo @@ -1422,9 +1429,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, do iazi=1, nazd do jk=1,klev do jl=1,klon - zpu(jl,jk,iazi) = 0.0 -! zcrt(jl,jk,iazi) = 0.0 -! zdfl(jl,jk,iazi) = 0.0 + zpu(jl,jk,iazi) = zero +! zcrt(jl,jk,iazi) = zero +! zdfl(jl,jk,iazi) = zero enddo enddo enddo @@ -1440,23 +1447,23 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! --------------------------------------------- do jk=max(ilaunch,2),klev do jl=1,klon - tvc1 = tm1(jl,jk) * (1. +fv*qm1(jl,jk)) - tvm1 = tm1(jl,jk-1) * (1. +fv*qm1(jl,jk-1)) + tvc1 = tm1(jl,jk) * (one +fv*qm1(jl,jk)) + tvm1 = tm1(jl,jk-1) * (one +fv*qm1(jl,jk-1)) ! zthm1(jl,jk) = 0.5 *(tvc1+tvm1) - 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)) + zthm1 = 2.0_r8 / (tvc1+tvm1) + zuhm1(jl,jk) = half *(um1(jl,jk-1)+um1(jl,jk)) + zvhm1(jl,jk) = half *(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) 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)) vueff(jl,jk) = - & 2.e-5*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min + & 2.e-5_r8*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min ! ! zbn2(jl,jk) = grav2cpd/zthm1(jl,jk) zbn2(jl,jk) = grav2cpd*zthm1 - & * (1.0+rcpdl*(tm1(jl,jk)-tm1(jl,jk-1))/zdelp) + & * (one+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) enddo @@ -1605,8 +1612,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! copy zflux into all other azimuths ! -------------------------------- -! zact(:,:,:) = 1.0 ; zacc(:,:,:) = 1.0 - zact(:,:,:) = 1.0 +! zact(:,:,:) = one ; zacc(:,:,:) = one + zact(:,:,:) = one do iazi=2, nazd do inc=1,nwav do jl=1,klon @@ -1674,9 +1681,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, do inc=1, nwav zcin = zci(inc) if (abs(zcin) > epsln) then - zcinc = 1.0 / zcin + zcinc = one / zcin else - zcinc = 1.0 + zcinc = one endif do jl=1,klon !======================================================================= @@ -1688,12 +1695,12 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, v_wdp = v_kxw*v_cdp wdop2 = v_wdp* v_wdp cdf2 = v_cdp*v_cdp - c2f2(jL) - if (cdf2 > 0) then + if (cdf2 > zero) then kzw2 = (zBn2(jL,jk)-wdop2)/Cdf2 - v_kxw2 else - kzw2 = 0.0 + kzw2 = zero endif - if ( kzw2 > 0 ) then + if ( kzw2 > zero ) then v_kzw = sqrt(kzw2) ! !linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 @@ -1706,10 +1713,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, v_kzi = abs(v_kzw*v_kzw*vueff(jl,jk)/v_wdp*v_kzw) expdis = exp(-v_kzi*v_zmet(jl,jk)) else - v_kzi = 0. - expdis = 1.0 - v_kzw = 0. - v_cdp = 0. ! no effects of reflected waves + v_kzi = zero + expdis = one + v_kzw = zero + v_cdp = zero ! no effects of reflected waves endif ! fmode = zflux(jl,inc,iazi) @@ -1725,7 +1732,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! flux_tot - sat.flux ! zdep = zact(jl,inc,iazi)* (fdis-zfluxs) - if(zdep > 0.0 ) then + if(zdep > zero ) then ! subs on sat-limit zflux(jl,inc,iazi) = zfluxs zflux_z(jl,inc,jk) = zfluxs @@ -1739,7 +1746,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! ! integrate over spectral modes zpu(y, z, azimuth) zact(jl,inc,iazi)*zflux(jl,inc,iazi)*[d("zcinc")] ! - zdfdz_v(:,jk,iazi) = 0.0 + zdfdz_v(:,jk,iazi) = zero do inc=1, nwav zcinc = zdci(inc) ! dc-integration @@ -1779,8 +1786,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! do jk=1,klev+1 do jl=1,klon - taux(jl,jk) = 0.0 - tauy(jl,jk) = 0.0 + taux(jl,jk) = zero + tauy(jl,jk) = zero enddo enddo @@ -1842,10 +1849,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, if (kdt == 1 .and. mpi_id == master) then print *, 'vgw done ' ! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay' + print *, maxval(pdudt)*86400, minval(pdudt)*86400, 'vgw ax' + print *, maxval(pdvdt)*86400, minval(pdvdt)*86400, 'vgw ay' print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps' + print *, maxval(pdtdt)*86400, minval(pdtdt)*86400,'vgw eps' ! ! print *, ' ugwp -heating rates ' endif From e1463756cd229b110eeccfb9876ce66621c7dfba Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 4 May 2020 18:38:48 +0000 Subject: [PATCH 16/30] removed tisfcin_cpl and tseain_cpl as they are not needed --- physics/GFS_debug.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 6bf39d491..4b62f0f9f 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -414,8 +414,8 @@ 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%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 ) From 513cb29b7572d3246b6cf44e7c857ddfdb23c13f Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 5 May 2020 01:02:55 +0000 Subject: [PATCH 17/30] minor update to surface_composites --- physics/GFS_surface_composites.F90 | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index e334c2468..7ad60a473 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -496,15 +496,24 @@ subroutine GFS_surface_composites_post_run ( tsfcl(i) = tsfc(i) if (.not. flag_cice(i)) then tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - elseif (wet(i) .and. cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice - txi = cice(i) - txo = one - txi - evap(i) = txi * evap_ice(i) + txo * evap_ocn(i) - hflx(i) = txi * hflx_ice(i) + txo * hflx_ocn(i) - tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_ocn(i) - stress(i) = txi * stress_ice(i) + txo * stress_ocn(i) - qss(i) = txi * qss_ice(i) + txo * qss_ocn(i) - ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_ocn(i) + elseif (wet(i)) then + if (cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_ocn(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_ocn(i) + tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_ocn(i) + stress(i) = txi * stress_ice(i) + txo * stress_ocn(i) + qss(i) = txi * qss_ice(i) + txo * qss_ocn(i) + ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_ocn(i) + else + evap(i) = evap_ocn(i) + hflx(i) = hflx_ocn(i) + tsfc(i) = tsfc_ocn(i) + stress(i) = stress_ocn(i) + qss(i) = qss_ocn(i) + ep1d(i) = ep1d_ocn(i) + endif endif if (wet(i)) then tsfco(i) = tsfc_ocn(i) From bbf56bb0c530bab0a1171dd32cf6be98c5854149 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 10 May 2020 01:13:12 +0000 Subject: [PATCH 18/30] merged with ccpp-physics, updated some code, tested coupled model with nsst model --- physics/GFS_PBL_generic.F90 | 53 +++++++------- physics/GFS_debug.F90 | 10 +-- physics/GFS_surface_composites.F90 | 6 +- physics/module_nst_model.f90 | 2 +- physics/sfc_nst.f | 112 ++++++++++++++++------------- physics/tridi.f | 22 +++--- 6 files changed, 109 insertions(+), 96 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 6d15a2f60..35d581749 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -92,6 +92,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, implicit none + integer, parameter :: r8 = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm @@ -115,9 +116,11 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + real (kind=kind_phys), parameter :: zero = 0.0_r8, one=1.0_r8 + ! Parameters for canopy heat storage parametrization - 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 :: z0min=0.2_r8, z0max=one + real (kind=kind_phys), parameter :: u10min=2.5_r8, u10max=7.5_r8 ! Local variables integer :: i, k, kk, k1, n @@ -283,20 +286,20 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, do i=1,im hflxq(i) = hflx(i) evapq(i) = evap(i) - hffac(i) = 1.0 - hefac(i) = 1.0 + hffac(i) = one + hefac(i) = one enddo if (lheatstrg) then do i=1,im - tem = 0.01 * zorl(i) ! change unit from cm to m + tem = 0.01_r8 * zorl(i) ! change unit from cm to m tem1 = (tem - z0min) / (z0max - z0min) - hffac(i) = z0fac * min(max(tem1, 0.0), 1.0) - tem = sqrt(u10m(i)**2+v10m(i)**2) + hffac(i) = z0fac * min(max(tem1, zero), one) + tem = sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i)) tem1 = (tem - u10min) / (u10max - u10min) - tem2 = 1.0 - min(max(tem1, 0.0), 1.0) + tem2 = one - min(max(tem1, zero), one) hffac(i) = tem2 * hffac(i) - hefac(i) = 1. + e0fac * hffac(i) - hffac(i) = 1. + hffac(i) + hefac(i) = one + e0fac * hffac(i) + hffac(i) = one + hffac(i) hflxq(i) = hflx(i) / hffac(i) evapq(i) = evap(i) / hefac(i) enddo @@ -339,6 +342,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, implicit none + integer, parameter :: r8 = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef logical, intent(in) :: trans_aero @@ -364,14 +368,14 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ! use assumed-shape arrays. Note that Intel 18 and GNU 6.2.0-8.1.0 tolerate explicit-shape arrays ! as long as these do not get used when not allocated. real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, dq3dt, dq3dt_ozone - real(kind=kind_phys), dimension(:), intent(inout) :: dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, & + real(kind=kind_phys), dimension(:), intent(inout) :: dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, & dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag logical, dimension(:),intent(in) :: wet, dry, icy real(kind=kind_phys), dimension(:), intent(out) :: ushfsfci real(kind=kind_phys), dimension(:,:), intent(inout) :: dkt_cpl - real(kind=kind_phys), dimension(:,:), intent(in) :: dkt + real(kind=kind_phys), dimension(:,:), intent(in) :: dkt ! From canopy heat storage - reduction factors in latent/sensible heat flux due to surface roughness real(kind=kind_phys), dimension(im), intent(in) :: hffac, hefac @@ -379,11 +383,10 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - real(kind=kind_phys), parameter :: zero = 0.0d0 - real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_r8, one = 1.0_r8 real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue, same as in GFS_typedefs.F90 - real(kind=kind_phys), parameter :: epsln = 1.0d-10 ! same as in GFS_physics_driver.F90 - real(kind=kind_phys), parameter :: qmin = 1.0d-8 + real(kind=kind_phys), parameter :: epsln = 1.0e-10_r8 ! same as in GFS_physics_driver.F90 + real(kind=kind_phys), parameter :: qmin = 1.0e-8_r8 integer :: i, k, kk, k1, n real(kind=kind_phys) :: tem, rho @@ -438,12 +441,12 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ! Ferrier-Aligo do k=1,levs do i=1,im - dqdt(i,k,ntqv) = 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,ntqv) = 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,nqrimef) = dvdftra(i,k,5) - dqdt(i,k,ntoz) = dvdftra(i,k,6) + dqdt(i,k,ntoz) = dvdftra(i,k,6) enddo enddo @@ -592,14 +595,14 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, !-------------------------------------------------------lssav if loop ---------- if (lssav) then do i=1,im - dusfc_diag (i) = dusfc_diag(i) + dusfc1(i)*dtf - dvsfc_diag (i) = dvsfc_diag(i) + dvsfc1(i)*dtf - dtsfc_diag (i) = dtsfc_diag(i) + dtsfc1(i)*hffac(i)*dtf - dqsfc_diag (i) = dqsfc_diag(i) + dqsfc1(i)*hefac(i)*dtf + dusfc_diag (i) = dusfc_diag(i) + dusfc1(i) * dtf + dvsfc_diag (i) = dvsfc_diag(i) + dvsfc1(i) * dtf dusfci_diag(i) = dusfc1(i) dvsfci_diag(i) = dvsfc1(i) dtsfci_diag(i) = dtsfc1(i)*hffac(i) dqsfci_diag(i) = dqsfc1(i)*hefac(i) + dtsfc_diag (i) = dtsfc_diag(i) + dtsfci_diag(i) * dtf + dqsfc_diag (i) = dqsfc_diag(i) + dqsfci_diag(i) * dtf enddo if (ldiag3d) then diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 4b62f0f9f..ac4641a4b 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -402,9 +402,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 ) @@ -416,8 +416,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, 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%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/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 7ad60a473..3e2248652 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -453,7 +453,6 @@ subroutine GFS_surface_composites_post_run ( fh2(i) = fh2_ocn(i) !tsurf(i) = tsurf_ocn(i) tsfco(i) = tsfc_ocn(i) ! over lake (and ocean when uncoupled) - if( cplflx ) tsfcl(i) = tsfc_ocn(i) ! for restart repro comparisons cmm(i) = cmm_ocn(i) chh(i) = chh_ocn(i) gflx(i) = gflx_ocn(i) @@ -492,8 +491,6 @@ subroutine GFS_surface_composites_post_run ( evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) qss(i) = qss_ice(i) - tsfc(i) = tsfc_ice(i) - tsfcl(i) = tsfc(i) if (.not. flag_cice(i)) then tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) elseif (wet(i)) then @@ -506,6 +503,7 @@ subroutine GFS_surface_composites_post_run ( stress(i) = txi * stress_ice(i) + txo * stress_ocn(i) qss(i) = txi * qss_ice(i) + txo * qss_ocn(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_ocn(i) + zorl(i) = txi * zorl_ice(i) + txo * zorl_ocn(i) else evap(i) = evap_ocn(i) hflx(i) = hflx_ocn(i) @@ -513,6 +511,7 @@ subroutine GFS_surface_composites_post_run ( stress(i) = stress_ocn(i) qss(i) = qss_ocn(i) ep1d(i) = ep1d_ocn(i) + zorl(i) = zorl_ocn(i) endif endif if (wet(i)) then @@ -520,6 +519,7 @@ subroutine GFS_surface_composites_post_run ( else tsfco(i) = tsfc(i) endif + tsfcl(i) = tsfc(i) endif zorll(i) = zorl_lnd(i) diff --git a/physics/module_nst_model.f90 b/physics/module_nst_model.f90 index 53bfb6be3..1e4d1a704 100644 --- a/physics/module_nst_model.f90 +++ b/physics/module_nst_model.f90 @@ -889,7 +889,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/physics/sfc_nst.f b/physics/sfc_nst.f index 3d0507ad9..8c7343519 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -164,7 +164,7 @@ subroutine sfc_nst_run & ! ===================================================================== ! use machine , only : kind_phys use funcphys, only : fpvs - use date_def, only: idate + use date_def, only : idate use module_nst_water_prop, only: get_dtzm_point use module_nst_parameters, only : t0k,cp_w,omg_m,omg_sh, & & sigma_r,solar_time_6am,ri_c,z_w_max,delz,wd_max, & @@ -178,11 +178,14 @@ subroutine sfc_nst_run & & dtl_reset ! implicit none + + integer, parameter :: r8 = kind_phys ! ! --- constant parameters: - real (kind=kind_phys), parameter :: f24 = 24.0 ! hours/day - real (kind=kind_phys), parameter :: f1440 = 1440.0 ! minutes/day - real (kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) + real (kind=kind_phys), parameter :: f24 = 24.0_r8 ! hours/day + real (kind=kind_phys), parameter :: f1440 = 1440.0_r8 ! minutes/day + real (kind=kind_phys), parameter :: czmin = 0.0001_r8 ! cos(89.994) + real (kind=kind_phys), parameter :: zero = 0.0_r8, one = 1.0_r8 ! --- inputs: @@ -252,11 +255,11 @@ subroutine sfc_nst_run & errmsg = '' errflg = 0 - cpinv = 1.0/cp - hvapi = 1.0/hvap + cpinv = one/cp + hvapi = one/hvap elocp = hvap/cp - sss = 34.0 ! temporarily, when sea surface salinity data is not ready + sss = 34.0_r8 ! temporarily, when sea surface salinity data is not ready ! ! flag for open water and where the iteration is on ! @@ -297,21 +300,21 @@ subroutine sfc_nst_run & nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) - q0(i) = max(q1(i), 1.0e-8) + q0(i) = max(q1(i), 1.0e-8_r8) #ifdef GSD_SURFACE_FLUXES_BUGFIX theta1(i) = t1(i) / prslk1(i) ! potential temperature at the middle of lowest model layer #else theta1(i) = t1(i) * prslki(i) #endif - tv1(i) = t1(i) * (1.0 + rvrdm1*q0(i)) + tv1(i) = t1(i) * (one + rvrdm1*q0(i)) rho_a(i) = prsl1(i) / (rd*tv1(i)) qss(i) = fpvs(tsurf(i)) ! pa qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa ! - evap(i) = 0.0 - hflx(i) = 0.0 - gflux(i) = 0.0 - ep(i) = 0.0 + evap(i) = zero + hflx(i) = zero + gflux(i) = zero + ep(i) = zero ! --- ... rcp = rho cp ch v @@ -337,8 +340,8 @@ subroutine sfc_nst_run & ! run nst model: dtm + slm ! - zsea1 = 0.001*real(nstf_name4) - zsea2 = 0.001*real(nstf_name5) + zsea1 = 0.001_r8*real(nstf_name4) + zsea2 = 0.001_r8*real(nstf_name5) !> - Call module_nst_water_prop::density() to compute sea water density. !> - Call module_nst_water_prop::rhocoef() to compute thermal expansion @@ -350,20 +353,20 @@ subroutine sfc_nst_run & ulwflx(i) = sfcemis(i) * sbc * t12 * t12 alon = xlon(i)*rad2deg grav = grv(sinlat(i)) - soltim = mod(alon/15.0 + solhr, 24.0)*3600.0 + soltim = mod(alon/15.0_r8 + solhr, 24.0_r8)*3600.0_r8 call density(tsea,sss,rho_w) ! sea water density call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta ! !> - Calculate sensible heat flux (\a qrain) due to rainfall. ! - le = (2.501-.00237*tsea)*1e6 - dwat = 2.11e-5*(t1(i)/t0k)**1.94 ! water vapor diffusivity - dtmp = (1.+3.309e-3*(t1(i)-t0k)-1.44e-6*(t1(i)-t0k)* - & (t1(i)-t0k))*0.02411/(rho_a(i)*cp) ! heat diffusivity + le = (2.501_r8-0.00237_r8*tsea)*1e6_r8 + dwat = 2.11e-5_r8*(t1(i)/t0k)**1.94_r8 ! water vapor diffusivity + dtmp = (one+3.309e-3_r8*(t1(i)-t0k)-1.44e-6_r8*(t1(i)-t0k) + & * (t1(i)-t0k))*0.02411_r8/(rho_a(i)*cp) ! heat diffusivity wetc = 622.0*le*qss(i)/(rd*t1(i)*t1(i)) - alfac = 1/(1+(wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor - qrain(i) = (1000.*rain(i)/rho_w)*alfac*cp_w* - & (tsea-t1(i)+(1000.*qss(i)-1000.*q0(i))*le/cp) + alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor + tem = (1.0e3_r8 * rain(i) / rho_w) * alfac * cp_w + qrain(i) = tem * (tsea-t1(i)+1.0e3_r8*(qss(i)-q0(i))*le/cp) !> - Calculate input non solar heat flux as upward = positive to models here @@ -379,10 +382,10 @@ subroutine sfc_nst_run & ! ! sensitivities of heat flux components to ts ! - rnl_ts = 4.0*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) + rnl_ts = 4.0_r8*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) hs_ts = rch(i) hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12) - rf_ts = (1000.*rain(i)/rho_w)*alfac*cp_w*(1.0+rch(i)*hl_ts) + rf_ts = tem * (one+rch(i)*hl_ts) q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts ! !> - Call cool_skin(), which is the sub-layer cooling parameterization @@ -393,7 +396,7 @@ subroutine sfc_nst_run & &, rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le &, dt_cool(i),z_c(i),c_0(i),c_d(i)) - tem = 1.0 / wndmag(i) + tem = one / wndmag(i) cosa = u1(i)*tem sina = v1(i)*tem taux = max(stress(i),tau_min)*cosa @@ -402,20 +405,20 @@ subroutine sfc_nst_run & ! ! Run DTM-1p system. ! - if ( (soltim > solar_time_6am .and. ifd(i) == 0.0) ) then + if ( (soltim > solar_time_6am .and. ifd(i) == zero) ) then else - ifd(i) = 1.0 + ifd(i) = one ! ! calculate fcl thickness with current forcing and previous time's profile ! ! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i) !> - Call convdepth() to calculate depth for convective adjustments. - if ( f_nsol > 0.0 .and. xt(i) > 0.0 ) then + if ( f_nsol > zero .and. xt(i) > zero ) then call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w &, alpha,beta,xt(i),xs(i),xz(i),d_conv(i)) else - d_conv(i) = 0.0 + d_conv(i) = zero endif ! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i) @@ -443,7 +446,7 @@ subroutine sfc_nst_run & ! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i) ! apply mda - if ( xt(i) > 0.0 ) then + if ( xt(i) > zero ) then !> - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply !! minimum depth adjustment (mda). call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i)) @@ -458,7 +461,7 @@ subroutine sfc_nst_run & endif ! apply fca - if ( d_conv(i) > 0.0 ) then + if ( d_conv(i) > zero ) then !> - If thickness of free convection layer > 0.0, call dtm_1p_fca() !! to apply free convection adjustment. !> - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset() @@ -483,7 +486,7 @@ subroutine sfc_nst_run & !> - Call cal_ttop() to calculate the diurnal warming amount at the top layer with !! thickness of \a dz. - if ( q_warm > 0.0 ) then + if ( q_warm > zero ) then call cal_ttop(kdt,timestep,q_warm,rho_w,dz, & xt(i),xz(i),ttop0) @@ -492,7 +495,7 @@ subroutine sfc_nst_run & ! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i), ! &' xz=',xz(i),' qrain=',qrain(i) - ttop = ((xt(i)+xt(i))/xz(i))*(1.0-dz/((xz(i)+xz(i)))) + ttop = ((xt(i)+xt(i))/xz(i))*(one-dz/((xz(i)+xz(i)))) ! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i) ! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz @@ -543,7 +546,7 @@ subroutine sfc_nst_run & ! endif ! if ( xt(i) > 0.0 ) then ! reset dtl at midnight and when solar zenith angle > 89.994 degree - if ( abs(soltim) < 2.0*timestep ) then + if ( abs(soltim) < 2.0_r8*timestep ) then call dtl_reset & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) endif @@ -556,17 +559,17 @@ subroutine sfc_nst_run & !> - Call get_dtzm_point() to computes \a dtz and \a tsurf. call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i), & zsea1,zsea2,dtz) - tsurf(i) = max(271.2, tref(i) + dtz ) + tsurf(i) = max(271.2_r8, tref(i) + dtz ) ! if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=', ! &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i) !> - Call cal_w() to calculate \a w_0 and \a w_d. - if ( xt(i) > 0.0 ) then + if ( xt(i) > zero ) then call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i)) else - w_0(i) = 0.0 - w_d(i) = 0.0 + w_0(i) = zero + w_d(i) = zero endif ! if ( xt(i) > 0.0 ) then @@ -634,7 +637,7 @@ subroutine sfc_nst_run & ! do i=1,im if ( flag(i) ) then - tem = 1.0 / rho_a(i) + tem = one / rho_a(i) hflx(i) = hflx(i) * tem * cpinv evap(i) = evap(i) * tem * hvapi endif @@ -682,6 +685,8 @@ subroutine sfc_nst_pre_run implicit none + integer, parameter :: r8 = kind_phys + ! --- inputs: integer, intent(in) :: im logical, dimension(im), intent(in) :: wet @@ -699,10 +704,10 @@ subroutine sfc_nst_pre_run ! --- locals integer :: i - real(kind=kind_phys), parameter :: zero = 0.0d0, - & one = 1.0d0, - & half = 0.5d0, - & omz1 = 10.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_r8, + & one = 1.0_r8, + & half = 0.5_r8, + & omz1 = 10.0_r8 real(kind=kind_phys) :: tem1, tem2, dt_warm ! Initialize CCPP error handling variables @@ -725,7 +730,11 @@ subroutine sfc_nst_pre_run tem1 = half / omz1 do i=1,im if (wet(i) .and. oceanfrac(i) > zero) then - tem2 = one / xz(i) + if (abs(xz(i)) > zero) then + tem2 = one / xz(i) + else + tem2 = zero + endif dt_warm = (xt(i)+xt(i)) * tem2 if ( xz(i) > omz1) then tref(i) = tseal(i) - (one-half*omz1*tem2) * dt_warm & @@ -735,7 +744,7 @@ subroutine sfc_nst_pre_run & - z_c(i)*dt_cool(i))*tem1 endif tseal(i) = tref(i) + dt_warm - dt_cool(i) -! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse +! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse tsurf_ocn(i) = tseal(i) endif enddo @@ -787,6 +796,8 @@ subroutine sfc_nst_post_run & implicit none + integer, parameter :: r8 = kind_phys + ! --- inputs: integer, intent(in) :: im logical, dimension(im), intent(in) :: wet, icy @@ -827,12 +838,11 @@ subroutine sfc_nst_post_run & ! --- ... run nsst model ... --- - dtzm = 0.0 + dtzm = 0.0_r8 if (nstf_name1 > 1) then - zsea1 = 0.001*real(nstf_name4) - zsea2 = 0.001*real(nstf_name5) - call get_dtzm_2d (xt, xz, dt_cool, & - & z_c, wet, zsea1, zsea2, & + zsea1 = 0.001_r8*real(nstf_name4) + zsea2 = 0.001_r8*real(nstf_name5) + call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, & & im, 1, dtzm) do i = 1, im ! if (wet(i) .and. .not.icy(i)) then diff --git a/physics/tridi.f b/physics/tridi.f index c8e77403b..0103b388f 100644 --- a/physics/tridi.f +++ b/physics/tridi.f @@ -41,21 +41,21 @@ subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) return end subroutine tridi1 -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- !>\ingroup satmedmf !>\ingroup satmedmfvdifq !> This subroutine .. subroutine tridi2(l,n,cl,cm,cu,r1,r2,au,a1,a2) -cc +! use machine , only : kind_phys implicit none integer, parameter :: one = 1.0_kind_phys integer k,n,l,i real(kind=kind_phys) fk -cc +! real(kind=kind_phys) cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n),r2(l,n), & & au(l,n-1),a1(l,n),a2(l,n) -c---------------------------------------------------------------------- +!---------------------------------------------------------------------- do i=1,l fk = one / cm(i,1) au(i,1) = fk*cu(i,1) @@ -81,29 +81,29 @@ subroutine tridi2(l,n,cl,cm,cu,r1,r2,au,a1,a2) a2(i,k) = a2(i,k)-au(i,k)*a2(i,k+1) enddo enddo -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- return end subroutine tridi2 -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- !>\ingroup satmedmf !>\ingroup satmedmfvdifq !> Routine to solve the tridiagonal system to calculate u- and !! v-momentum at \f$ t + \Delta t \f$; part of two-part process to !! calculate time tendencies due to vertical diffusion. subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) -cc +! use machine , only : kind_phys implicit none integer, parameter :: one = 1.0_kind_phys integer is,k,kk,n,nt,l,i real(kind=kind_phys) fk(l) -cc +! real(kind=kind_phys) cl(l,2:n), cm(l,n), cu(l,n-1), & & r1(l,n), r2(l,n*nt), & & au(l,n-1), a1(l,n), a2(l,n*nt), & & fkk(l,2:n-1) -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- do i=1,l fk(i) = one / cm(i,1) au(i,1) = fk(i)*cu(i,1) @@ -153,11 +153,11 @@ subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) enddo enddo enddo -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- return end subroutine tridin -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- !>\ingroup satmedmf !>\ingroup satmedmfvdifq !! This subroutine solves tridiagonal problem for TKE. From 3cdcdaab7261ffb212e0c36b6eeff34880429cb4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 11 May 2020 01:19:18 +0000 Subject: [PATCH 19/30] change 633.0 to 622.0_r8 --- physics/sfc_nst.f | 2 +- physics/sfc_ocean.F | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 8c7343519..857506686 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -363,7 +363,7 @@ subroutine sfc_nst_run & dwat = 2.11e-5_r8*(t1(i)/t0k)**1.94_r8 ! water vapor diffusivity dtmp = (one+3.309e-3_r8*(t1(i)-t0k)-1.44e-6_r8*(t1(i)-t0k) & * (t1(i)-t0k))*0.02411_r8/(rho_a(i)*cp) ! heat diffusivity - wetc = 622.0*le*qss(i)/(rd*t1(i)*t1(i)) + wetc = 622.0_r8*le*qss(i)/(rd*t1(i)*t1(i)) alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor tem = (1.0e3_r8 * rain(i) / rho_w) * alfac * cp_w qrain(i) = tem * (tsea-t1(i)+1.0e3_r8*(qss(i)-q0(i))*le/cp) diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index d937ddf49..bdd7ea6b0 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -149,6 +149,7 @@ subroutine sfc_ocean_run & ep(i) = evap(i) qsurf(i) = qss + gflux(i) = zero endif enddo ! From 4c08f739c121af21483e832cd29b4f3d34c9361e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 18 May 2020 21:00:06 -0400 Subject: [PATCH 20/30] updating nst model coupled with ocean model --- physics/module_nst_water_prop.f90 | 86 ++++++++++++++----------------- physics/sfc_nst.f | 34 ++++++------ 2 files changed, 55 insertions(+), 65 deletions(-) diff --git a/physics/module_nst_water_prop.f90 b/physics/module_nst_water_prop.f90 index 3f3916396..81e31b148 100644 --- a/physics/module_nst_water_prop.f90 +++ b/physics/module_nst_water_prop.f90 @@ -60,8 +60,8 @@ subroutine rhocoef(t, s, rhoref, alpha, beta) tc = t - t0k - alpha = & - 6.793952e-2 & + 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 & @@ -73,7 +73,7 @@ subroutine rhocoef(t, s, rhoref, alpha, beta) ! 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 & @@ -109,10 +109,10 @@ subroutine density(t, s, rho) ! effect of temperature on density (lines 1-3) ! effect of temperature and salinity on density (lines 4-8) - rho = & - 999.842594 + 6.793952e-2 * tc & - - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & - - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & + rho = & + 999.842594 + 6.793952e-2 * tc & + - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & + - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & + 8.24493e-1 * s - 4.0899e-3 * tc * s & + 7.6438e-5 * tc**2 * s - 8.2467e-7 * tc**3 * s & + 5.3875e-9 * tc**4 * s - 5.72466e-3 * s**1.5 & @@ -415,9 +415,9 @@ elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) real(kind=kind_phys),intent(out):: 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)) & + 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)) & +.45*12.82*(1.-exp(-z/12.82)))/z & ) else @@ -444,9 +444,9 @@ elemental subroutine sw_soloviev_3exp_v2_aw(z,aw) real(kind=kind_phys):: fxp ! if(z>0) then - fxp=(1.0 & - -(0.28*0.014*(1.-exp(-z/0.014)) & - + 0.27*0.357*(1.-exp(-z/0.357)) & + fxp=(1.0 & + -(0.28*0.014*(1.-exp(-z/0.014)) & + + 0.27*0.357*(1.-exp(-z/0.357)) & + 0.45*12.82*(1.-exp(-z/12.82)))/z & ) aw=1.0-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82)) @@ -702,69 +702,59 @@ 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 - -! DH* NEED NTHREADS HERE! TODO -!$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 +! end subroutine get_dtzm_2d diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 857506686..6022d229f 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -682,6 +682,7 @@ subroutine sfc_nst_pre_run & z_c, tref, cplflx, oceanfrac, errmsg, errflg) use machine , only : kind_phys + use module_nst_water_prop, only: get_dtzm_2d implicit none @@ -707,8 +708,9 @@ subroutine sfc_nst_pre_run real(kind=kind_phys), parameter :: zero = 0.0_r8, & one = 1.0_r8, & half = 0.5_r8, - & omz1 = 10.0_r8 - real(kind=kind_phys) :: tem1, tem2, dt_warm + & omz1 = 2.0_r8 + real(kind=kind_phys) :: tem1, tem2, dt_warm, dnsst + real(kind=kind_phys), dimension(im) :: dtzm ! Initialize CCPP error handling variables errmsg = '' @@ -720,31 +722,30 @@ subroutine sfc_nst_pre_run ! DH* 20190927 simplyfing this code because tem is zero !tem = zero !tseal(i) = tsfc_ocn(i) + tem - tseal(i) = tsfc_ocn(i) + tseal(i) = tsfc_ocn(i) !tsurf_ocn(i) = tsurf_ocn(i) + tem ! *DH endif enddo +! +! update tsfc & tref with T1 from OGCM & NSST Profile if coupled +! if (cplflx) then - tem1 = half / omz1 + call get_dtzm_2d (xt, xz, dt_cool, & + & z_c, wet, zero, omz1, im, 1, dtzm) do i=1,im if (wet(i) .and. oceanfrac(i) > zero) then +! dnsst = tsfc_ocn(i) - tref(i) ! retrive/get difference of Ts and Tf + tref(i) = tsfc_ocn(i) - dtzm(i) ! update Tf with T1 and NSST T-Profile +! tsfc_ocn(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update +! tseal(i) = tsfc_ocn(i) if (abs(xz(i)) > zero) then tem2 = one / xz(i) else tem2 = zero endif - dt_warm = (xt(i)+xt(i)) * tem2 - if ( xz(i) > omz1) then - tref(i) = tseal(i) - (one-half*omz1*tem2) * dt_warm & - & + z_c(i)*dt_cool(i)*tem1 - else - tref(i) = tseal(i) - (xz(i)*dt_warm & - & - z_c(i)*dt_cool(i))*tem1 - endif - tseal(i) = tref(i) + dt_warm - dt_cool(i) -! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse + tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i) tsurf_ocn(i) = tseal(i) endif enddo @@ -838,15 +839,14 @@ subroutine sfc_nst_post_run & ! --- ... run nsst model ... --- - dtzm = 0.0_r8 if (nstf_name1 > 1) then zsea1 = 0.001_r8*real(nstf_name4) zsea2 = 0.001_r8*real(nstf_name5) call get_dtzm_2d (xt, xz, dt_cool, 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 +! if (wet(i) .and. .not.icy(i)) then +! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then if (wet(i)) then tsfc_ocn(i) = max(tgice, tref(i) + dtzm(i)) ! tsfc_ocn(i) = max(271.2, tref(i) + dtzm(i)) - & From d810799b637173f14360bad7727ef9f05a0351ba Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 27 May 2020 20:16:24 -0400 Subject: [PATCH 21/30] some fix related to ice in surface cycling --- physics/gcycle.F90 | 30 ++++++++++++------------ physics/sfcsub.F | 57 ++++++++++++++++++++++++++-------------------- 2 files changed, 47 insertions(+), 40 deletions(-) diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index ad627233b..f750f6769 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -84,22 +84,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) @@ -142,18 +142,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/physics/sfcsub.F b/physics/sfcsub.F index f9c3af1f7..ee4a2ec09 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -2416,7 +2416,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) @@ -2435,7 +2435,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) @@ -2444,38 +2444,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 ! @@ -7323,8 +7331,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 @@ -8133,8 +8140,7 @@ end subroutine clima !>\ingroup mod_sfcsub 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 @@ -8151,7 +8157,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 8b77f369475e949bc1735c33e340a97d09f59c82 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 14 Jun 2020 23:52:12 +0000 Subject: [PATCH 22/30] updating sfc_diff.f to compute z0 overocean when ww3 sends z0 values <= 0.0 --- physics/sfc_diff.f | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 81aacc19a..53837cac5 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -356,15 +356,25 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) elseif (sfc_z0_type == 6) then ! wang call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m - z0rl_ocn(i) = 100.0_r8 * z0 ! cm + z0rl_ocn(i) = 100.0_r8 * z0 ! cm elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m - z0rl_ocn(i) = 100.0_r8 * z0 ! cm + call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m + z0rl_ocn(i) = 100.0_r8 * z0 ! cm else z0rl_ocn(i) = 1.0e-4_r8 endif + elseif (z0rl_ocn(i) <= 0.0_r8) then + z0 = (charnock / grav) * ustar_ocn(i) * ustar_ocn(i) + + if (redrag) then + z0rl_ocn(i) = 100.0_r8 * max(min(z0, z0s_max),1.0e-7_r8) + else + z0rl_ocn(i) = 100.0_r8 * max(min(z0,0.1_r8), 1.e-7_r8) + endif + endif + endif ! end of if(open ocean) ! endif ! end of if(flagiter) loop From 37444dc7da2af9399c17c1c9bd63b100ea0fd81c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 29 Jun 2020 23:38:57 +0000 Subject: [PATCH 23/30] updating sfc_diff.f to recompute z0 over ocean when coupled to ww3 and value is below 1.0e-7 --- physics/sfc_diff.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 2a52b28c4..3ec69cd4f 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -355,13 +355,13 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0rl_wat(i) = 1.0e-4_r8 endif - elseif (z0rl_wat(i) <= 0.0_r8) then + elseif (z0rl_wat(i) <= 1.0e-7_r8) then z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) if (redrag) then z0rl_wat(i) = 100.0_r8 * max(min(z0, z0s_max),1.0e-7_r8) else - z0rl_wat(i) = 100.0_r8 * max(min(z0,0.1_r8), 1.e-7_r8) + z0rl_wat(i) = 100.0_r8 * max(min(z0,0.1_r8), 1.0e-7_r8) endif endif From 3af3d7f9b1ae847662958ffbebba28e79ef23bf4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 8 Jul 2020 00:49:55 +0000 Subject: [PATCH 24/30] fixing errors/logic with fractional grid option to reproduce a continuous run from a restart run - works for both NEMS mediator and CMEPS --- physics/GFS_surface_composites.F90 | 65 +++++++++++++++++++++-------- physics/GFS_surface_composites.meta | 24 +++++++++-- physics/GFS_surface_generic.F90 | 1 + physics/gcycle.F90 | 11 ++--- physics/sfc_sice.f | 55 ++++++++++++++---------- physics/sfc_sice.meta | 64 ++++++++++++++-------------- 6 files changed, 142 insertions(+), 78 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index cb0b24320..96dc88949 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -26,7 +26,7 @@ end subroutine GFS_surface_composites_pre_finalize !! subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cplwav2atm, & landfrac, lakefrac, oceanfrac, & - frland, dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorl_wat, & + frland, dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorli, zorl_wat, & zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_lnd, uustar_ice, weasd, weasd_wat, & weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, & @@ -47,7 +47,7 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl real(kind=kind_phys), dimension(im), intent( out) :: frland real(kind=kind_phys), dimension(im), intent(in ) :: zorl, snowd, tprcp, uustar, weasd - real(kind=kind_phys), dimension(im), intent(inout) :: zorlo, zorll, tsfc, tsfco, tsfcl, tisfc, tsurf + real(kind=kind_phys), dimension(im), intent(inout) :: zorlo, zorll, zorli, tsfc, tsfco, tsfcl, tisfc, tsurf real(kind=kind_phys), dimension(im), intent(inout) :: snowd_wat, snowd_lnd, snowd_ice, tprcp_wat, & tprcp_lnd, tprcp_ice, zorl_wat, zorl_lnd, zorl_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat, & tsurf_lnd, tsurf_ice, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, gflx_ice @@ -77,23 +77,31 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl if (flag_cice(i)) then if (cice(i) >= min_seaice) then icy(i) = .true. + if (cice(i) < one) wet(i) = .true. ! some open ocean/lake water exists else - cice(i) = zero - flag_cice(i) = .false. - islmsk(i) = 0 + cice(i) = zero + flag_cice(i) = .false. +! islmsk_cice(i) = 0 +! islmsk(i) = 0 + wet(i) = .true. ! some open ocean/lake water exists endif else if (cice(i) >= min_lakeice) then icy(i) = .true. + if (cice(i) < one) wet(i) = .true. ! some open ocean/lake water exists + islmsk(i) = 2 else cice(i) = zero - islmsk(i) = 0 +! islmsk(i) = 0 + wet(i) = .true. ! some open ocean/lake water exists endif endif - if (cice(i) < one ) then - wet(i) = .true. ! some open ocean/lake water exists - if ((.not. cplflx .or. oceanfrac(i) == zero) .and. icy(i)) & - tsfco(i) = max(tisfc(i), tgice) + if (wet(i) .and. .not. cplflx) then + if (oceanfrac(i) > zero) then + tsfco(i) = max(tsfco(i), tisfc(i), tgice) + elseif (icy(i)) then + tsfco(i) = max(tisfc(i), tgice) + endif endif else cice(i) = zero @@ -173,7 +181,7 @@ subroutine GFS_surface_composites_pre_run (im, frac_grid, flag_cice, cplflx, cpl if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) weasd_ice(i) = weasd(i) - zorl_ice(i) = zorll(i) + zorl_ice(i) = zorli(i) tsfc_ice(i) = tisfc(i) tsurf_ice(i) = tisfc(i) snowd_ice(i) = snowd(i) @@ -296,7 +304,7 @@ end subroutine GFS_surface_composites_post_finalize #endif subroutine GFS_surface_composites_post_run ( & im, kice, km, cplflx, cplwav2atm, frac_grid, flag_cice, islmsk, dry, wet, icy, landfrac, lakefrac, oceanfrac, & - zorl, zorlo, zorll, zorl_wat, zorl_lnd, zorl_ice, & + zorl, zorlo, zorll, zorli, zorl_wat, zorl_lnd, zorl_ice, & cd, cd_wat, cd_lnd, cd_ice, cdq, cdq_wat, cdq_lnd, cdq_ice, rb, rb_wat, rb_lnd, rb_ice, stress, stress_wat, stress_lnd, & stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & @@ -319,7 +327,7 @@ subroutine GFS_surface_composites_post_run ( snowd_wat, snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice - real(kind=kind_phys), dimension(im), intent(inout) :: zorl, zorlo, zorll, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & + real(kind=kind_phys), dimension(im), intent(inout) :: zorl, zorlo, zorll, zorli, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & fh2, tsurf, cmm, chh, gflx, ep1d, weasd, snowd, tprcp, evap, hflx, qss, tsfc, tsfco, tsfcl, tisfc real(kind=kind_phys), dimension(im), intent(in ) :: tice ! interstitial sea ice temperature @@ -361,7 +369,7 @@ subroutine GFS_surface_composites_post_run ( uustar(i) = txl*uustar_lnd(i) + txi*uustar_ice(i) + txo*uustar_wat(i) fm10(i) = txl*fm10_lnd(i) + txi*fm10_ice(i) + txo*fm10_wat(i) fh2(i) = txl*fh2_lnd(i) + txi*fh2_ice(i) + txo*fh2_wat(i) - !tsurf(i) = txl*tsurf_lnd(i) + txi*tice(i) + txo*tsurf_wat(i) + !tsurf(i) = txl*tsurf_lnd(i) + txi*tice(i) + txo*tsurf_wat(i) !tsurf(i) = txl*tsurf_lnd(i) + txi*tsurf_ice(i) + txo*tsurf_wat(i) ! not used again! Moorthi cmm(i) = txl*cmm_lnd(i) + txi*cmm_ice(i) + txo*cmm_wat(i) chh(i) = txl*chh_lnd(i) + txi*chh_ice(i) + txo*chh_wat(i) @@ -388,10 +396,30 @@ subroutine GFS_surface_composites_post_run ( tsfc(i) = txl*tsfc_lnd(i) + txi*tice(i) + txo*tsfc_wat(i) zorll(i) = zorl_lnd(i) + zorli(i) = zorl_ice(i) zorlo(i) = zorl_wat(i) - if (dry(i)) tsfcl(i) = tsfc_lnd(i) ! over land - if (wet(i)) tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled + if (dry(i)) then + tsfcl(i) = tsfc_lnd(i) ! over land + elseif (wet(i)) then + tsfcl(i) = tsfc_wat(i) ! over water + else + tsfcl(i) = tice(i) ! over ice + endif + if (wet(i)) then + tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled + elseif (icy(i)) then + tsfco(i) = tice(i) ! over lake or ocean ice when uncoupled + else + tsfco(i) = tsfc_lnd(i) ! over land + endif + if (icy(i)) then + tisfc(i) = tice(i) ! over lake or ocean ice when uncoupled + elseif (wet(i)) then + tisfc(i) = tsfc_wat(i) ! over lake or ocean when uncoupled + else + tisfc(i) = tsfc_lnd(i) ! over land + endif ! for coupled model ocean will replace this ! if (icy(i)) tisfc(i) = tsfc_ice(i) ! over ice when uncoupled ! if (icy(i)) tisfc(i) = tice(i) ! over ice when uncoupled @@ -402,9 +430,9 @@ subroutine GFS_surface_composites_post_run ( ! 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 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) hice(i) = zero cice(i) = zero tisfc(i) = tsfc(i) @@ -530,6 +558,7 @@ subroutine GFS_surface_composites_post_run ( zorll(i) = zorl_lnd(i) zorlo(i) = zorl_wat(i) + zorli(i) = zorl_ice(i) enddo diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index f58eddc2f..0f9c065f3 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -162,6 +162,15 @@ kind = kind_phys intent = inout optional = F +[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 + intent = inout + optional = F [zorl_wat] standard_name = surface_roughness_length_over_ocean_interstitial long_name = surface roughness length over ocean (temporary use as interstitial) @@ -506,7 +515,7 @@ [min_lakeice] standard_name = lake_ice_minimum long_name = minimum lake ice value - units = ??? + units = frac dimensions = () type = real kind = kind_phys @@ -515,7 +524,7 @@ [min_seaice] standard_name = sea_ice_minimum long_name = minimum sea ice value - units = ??? + units = frac dimensions = () type = real kind = kind_phys @@ -829,6 +838,15 @@ kind = kind_phys intent = inout optional = F +[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 + intent = inout + optional = F [zorl_wat] standard_name = surface_roughness_length_over_ocean_interstitial long_name = surface roughness length over ocean (temporary use as interstitial) @@ -1669,7 +1687,7 @@ [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/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index b05a84173..c7032866d 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -141,6 +141,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, do i=1,im sigmaf(i) = max(vfrac(i), 0.01_kind_phys) + islmsk_cice(i) = islmsk(i) if (islmsk(i) == 2) then if (isot == 1) then soiltyp(i) = 16 diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index bffcbefa5..f92ee8821 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -67,7 +67,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 ! !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @@ -244,10 +244,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) - if (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (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/physics/sfc_sice.f b/physics/sfc_sice.f index 7e55f7244..ab67f849e 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -43,11 +43,12 @@ subroutine sfc_sice_run & & ( im, kice, sbc, hvap, tgice, cp, eps, epsm1, rvrdm1, grav, & ! --- inputs: & t0c, rd, ps, t1, q1, delt, & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & - & cm, ch, prsl1, prslki, prsik1, prslk1, islimsk, wind, & - & flag_iter, lprnt, ipr, cimin, & + & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & + & flag_iter, lprnt, ipr, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & ! - & cplflx, cplchm, flag_cice, islmsk_cice, & + & frac_grid, icy, islmsk_cice, & + & min_lakeice, min_seaice, oceanfrac, & & errmsg, errflg & ) @@ -60,10 +61,10 @@ subroutine sfc_sice_run & ! inputs: ! ! ( im, kice, ps, t1, q1, delt, ! ! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! -! cm, ch, prsl1, prslki, prsik1, prslk1, islimsk, wind, ! +! cm, ch, prsl1, prslki, prsik1, prslk1, wind, ! ! flag_iter, ! ! input/outputs: ! -! hice, fice, tice, weasd, tskin, tprcp, tiice, ep, ! +! hice, fice, tice, weasd, tskin, tprcp, tiice, ep, ! ! outputs: ! ! snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx ) ! ! ! @@ -151,21 +152,21 @@ subroutine sfc_sice_run & ! --- inputs: integer, intent(in) :: im, kice, ipr logical, intent(in) :: lprnt - logical, intent(in) :: cplflx - logical, intent(in) :: cplchm + logical, intent(in) :: frac_grid real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & & epsm1, grav, rvrdm1, t0c, rd real (kind=kind_phys), dimension(im), intent(in) :: ps, & & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & - & prsl1, prslki, prsik1, prslk1, wind + & prsl1, prslki, prsik1, prslk1, wind, oceanfrac - integer, dimension(im), intent(in) :: islimsk +! integer, dimension(im), intent(in) :: islimsk integer, dimension(im), intent(in) :: islmsk_cice - real (kind=kind_phys), intent(in) :: delt, cimin + real (kind=kind_phys), intent(in) :: delt, min_seaice, & + & min_lakeice - logical, dimension(im), intent(in) :: flag_iter, flag_cice + logical, dimension(im), intent(in) :: flag_iter, icy ! --- input/outputs: real (kind=kind_phys), dimension(im), intent(inout) :: hice, & @@ -189,7 +190,7 @@ subroutine sfc_sice_run & real (kind=kind_phys) :: t12, t14, tem, stsice(im,kice) &, hflxi, hflxw, q0, qs1, qssi, qssw - real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw + real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin integer :: i, k integer, dimension(im) :: islmsk_local @@ -207,15 +208,22 @@ subroutine sfc_sice_run & errflg = 0 - if (cplflx) then - where (flag_cice) - islmsk_local = islmsk_cice - elsewhere - islmsk_local = islimsk - endwhere - else - islmsk_local = islimsk - end if + islmsk_local = islmsk_cice + if (frac_grid) then + do i=1,im + if (icy(i) .and. islmsk_local(i) < 2) then + if (oceanfrac(i) > zero) then + tem = min_seaice + else + tem = min_lakeice + endif + if (fice(i) > tem) then + islmsk_local(i) = 2 + tice(i) =min( tice(i), tgice) + endif + endif + enddo + endif ! !> - Set flag for sea-ice. @@ -255,6 +263,11 @@ subroutine sfc_sice_run & do i = 1, im if (flag(i)) then + if (oceanfrac(i) > zero) then + cimin = min_seaice + else + cimin = min_lakeice + endif ! psurf(i) = 1000.0 * ps(i) ! ps1(i) = 1000.0 * prsl1(i) diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index dc08e0170..a05f2e4d6 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -242,14 +242,6 @@ kind = kind_phys intent = in optional = F -[islimsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_dimension) - type = integer - intent = in - optional = F [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level @@ -283,15 +275,6 @@ type = integer intent = in optional = F -[cimin] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = ??? - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [hice] standard_name = sea_ice_thickness long_name = sea-ice thickness @@ -436,25 +419,17 @@ kind = kind_phys intent = inout optional = F -[cplflx] - standard_name = flag_for_flux_coupling - long_name = flag controlling cplflx collection (default off) +[frac_grid] + standard_name = flag_for_fractional_grid + long_name = flag for fractional grid units = flag dimensions = () type = logical intent = in optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction units = flag dimensions = (horizontal_dimension) type = logical @@ -468,6 +443,33 @@ type = integer intent = in optional = F +[min_lakeice] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 21f7fddfd1885896a2ac282c093c9529b10e1bd6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 20 Jul 2020 19:02:16 +0000 Subject: [PATCH 25/30] some minor fixes --- physics/GFS_MP_generic.F90 | 48 +++++++------------------------ physics/GFS_PBL_generic.F90 | 2 +- physics/GFS_rrtmg_pre.F90 | 4 +-- physics/GFS_time_vary_pre.fv3.F90 | 2 +- 4 files changed, 14 insertions(+), 42 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 68c19df42..8810cc7cf 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -253,40 +253,6 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, endif - if (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 - cnvprcp (i) = cnvprcp (i) + rainc(i) - totprcp (i) = totprcp (i) + rain(i) - totice (i) = totice (i) + ice(i) - totsnw (i) = totsnw (i) + snow(i) - totgrp (i) = totgrp (i) + graupel(i) - - cnvprcpb(i) = cnvprcpb(i) + rainc(i) - totprcpb(i) = totprcpb(i) + rain(i) - toticeb (i) = toticeb (i) + ice(i) - totsnwb (i) = totsnwb (i) + snow(i) - totgrpb (i) = totgrpb (i) + graupel(i) - enddo - - if (ldiag3d) then - do k=1,levs - do i=1,im - dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain - enddo - enddo - if (qdiag3d) then - do k=1,levs - do i=1,im - dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain - enddo - enddo - endif - endif - endif - t850(1:im) = gt0(1:im,1) do k = 1, levs-1 @@ -365,9 +331,9 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, endif if (lssav) then -! if (Model%me == 0) print *,'in phys drive, kdt=',kdt, & -! 'totprcpb=', totprcpb(1),'totprcp=',totprcp(1), & -! 'rain=',rain(1) +! 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 cnvprcp (i) = cnvprcp (i) + rainc(i) totprcp (i) = totprcp (i) + rain(i) @@ -386,9 +352,15 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, do k=1,levs do i=1,im dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain -! dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain enddo enddo + if (qdiag3d) then + do k=1,levs + do i=1,im + dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain + enddo + enddo + endif endif endif diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 77a1aa86f..f3eb212c7 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -626,7 +626,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, if(qdiag3d) then do k=1,levs do i=1,im - dq3dt(i,k) = dq3dt(i,k) + (qgrs(i,k,ntqv)-save_q(i,k,ntqv)) + dq3dt (i,k) = dq3dt (i,k) + (qgrs(i,k,ntqv)-save_q(i,k,ntqv)) dq3dt_ozone(i,k) = dq3dt_ozone(i,k) + (qgrs(i,k,ntoz)-save_q(i,k,ntoz)) enddo enddo diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 5116d20b1..cc5b31447 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -141,13 +141,13 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: cvt1, cvb1, tem1d, tskn - real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP) :: & + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP) :: & htswc, htlwc, gcice, grain, grime, htsw0, htlw0, & rhly, tvly,qstl, vvel, clw, ciw, prslk1, tem2da, & cldcov, deltaq, cnvc, cnvw, & effrl, effri, effrr, effrs, rho, orho ! for Thompson MP - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: & + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP) :: & re_cloud, re_ice, re_snow, qv_mp, qc_mp, & qi_mp, qs_mp, nc_mp, ni_mp, nwfa diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 98a0f6697..6a21199e9 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -171,7 +171,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & if (nslwr == 1) lslwr = .true. !--- allow for radiation to be called on every physics time step ! for the first nhfrad timesteps (for spinup, coldstarts only) - if (kdt<=nhfrad) then + if (kdt <= nhfrad) then lsswr = .true. lslwr = .true. end if From c2c4492d1c137a54eae76a6aa3c83515a1e36f35 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 22 Jul 2020 11:07:36 +0000 Subject: [PATCH 26/30] updating sfx_diff to fix issues related to coupling to waves --- physics/sfc_diff.f | 4 +++- physics/sfc_diff.meta | 9 +++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 3ec69cd4f..f84da9bec 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -72,6 +72,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) & snwdph_wat,snwdph_lnd,snwdph_ice, & !intent(in) & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) + & z0rl_wav, & !intent(inout) & ustar_wat, ustar_lnd, ustar_ice, & !intent(inout) & cm_wat, cm_lnd, cm_ice, & !intent(inout) & ch_wat, ch_lnd, ch_ice, & !intent(inout) @@ -105,6 +106,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & & snwdph_wat,snwdph_lnd,snwdph_ice + real(kind=kind_phys), dimension(im), intent(in) :: z0rl_wav real(kind=kind_phys), dimension(im), intent(inout) :: & & z0rl_wat, z0rl_lnd, z0rl_ice, & & ustar_wat, ustar_lnd, ustar_ice, & @@ -355,7 +357,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0rl_wat(i) = 1.0e-4_r8 endif - elseif (z0rl_wat(i) <= 1.0e-7_r8) then + elseif (z0rl_wav(i) <= 1.0e-7_r8) then z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) if (redrag) then diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index ab99dcb06..ea109c9e5 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -352,6 +352,15 @@ kind = kind_phys intent = inout optional = F +[z0rl_wav] + 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 + intent = in + optional = F [ustar_wat] standard_name = surface_friction_velocity_over_ocean long_name = surface friction velocity over ocean From 70ba799f342c05e61e74cf31123b0343a25d14d5 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 27 Jul 2020 23:48:43 +0000 Subject: [PATCH 27/30] fixing bug in orho in GFS_rrtmg_pre.F90 --- physics/GFS_rrtmg_pre.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index cc5b31447..ca7695528 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -590,7 +590,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input qc_mp (i,k) = tracer1(i,k,ntcw)/(1.-qvs) qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) - nc_mp (i,k) = nt_c*orho(i,k1) + nc_mp (i,k) = nt_c*orho(i,k) ni_mp (i,k) = tracer1(i,k,ntinc)/(1.-qvs) enddo enddo From cfb269cedfc42a9016c18331cd9cf3bdba7f4a9f Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 28 Jul 2020 14:50:53 +0000 Subject: [PATCH 28/30] adding nthreads to sfc_nst.f --- physics/module_nst_water_prop.f90 | 7 ++++--- physics/sfc_nst.f | 12 ++++++------ physics/sfc_nst.meta | 16 ++++++++++++++++ 3 files changed, 26 insertions(+), 9 deletions(-) diff --git a/physics/module_nst_water_prop.f90 b/physics/module_nst_water_prop.f90 index 81e31b148..39020526c 100644 --- a/physics/module_nst_water_prop.f90 +++ b/physics/module_nst_water_prop.f90 @@ -657,7 +657,7 @@ subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm) end subroutine get_dtzm_point !>\ingroup waterprop - subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) + subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,nth,dtm) !subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) ! ===================================================================== ! ! ! @@ -687,6 +687,7 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) ! ny - integer, dimension in y-direction (meridional) 1 ! ! z1 - lower bound of depth of sea temperature 1 ! ! z2 - upper bound of depth of sea temperature 1 ! +! nth - integer, num of openmp thread 1 ! ! outputs: ! ! dtm - mean of dT(z) (z1 to z2) 1 ! ! @@ -694,7 +695,7 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) implicit none - integer, intent(in) :: nx,ny + integer, intent(in) :: nx,ny, nth real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc logical, dimension(nx,ny), intent(in) :: wet ! logical, dimension(nx,ny), intent(in) :: wet,icy @@ -706,7 +707,7 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) real (kind=kind_phys), parameter :: zero=0.0, half=0.5, one=1.0 -!$omp parallel do private(j,i,dtw,dtc,xzi) +!$omp parallel do num_threads (nth) private(j,i,dtw,dtc,xzi) do j = 1, ny do i= 1, nx diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 72982e248..cfe191a85 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -676,7 +676,7 @@ end subroutine sfc_nst_pre_finalize !! @{ subroutine sfc_nst_pre_run & (im, wet, tsfc_wat, tsurf_wat, tseal, xt, xz, dt_cool, - & z_c, tref, cplflx, oceanfrac, errmsg, errflg) + & z_c, tref, cplflx, oceanfrac, nthreads, errmsg, errflg) use machine , only : kind_phys use module_nst_water_prop, only: get_dtzm_2d @@ -686,7 +686,7 @@ subroutine sfc_nst_pre_run integer, parameter :: r8 = kind_phys ! --- inputs: - integer, intent(in) :: im + integer, intent(in) :: im, nthreads logical, dimension(im), intent(in) :: wet real (kind=kind_phys), dimension(im), intent(in) :: & tsfc_wat, xt, xz, dt_cool, z_c, oceanfrac @@ -730,7 +730,7 @@ subroutine sfc_nst_pre_run ! if (cplflx) then call get_dtzm_2d (xt, xz, dt_cool, & - & z_c, wet, zero, omz1, im, 1, dtzm) + & z_c, wet, zero, omz1, im, 1, nthreads, dtzm) do i=1,im if (wet(i) .and. oceanfrac(i) > zero) then ! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf @@ -786,7 +786,7 @@ end subroutine sfc_nst_post_finalize subroutine sfc_nst_post_run & & ( im, rlapse, tgice, wet, icy, oro, oro_uf, nstf_name1, & & nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & - & tsurf_wat, tsfc_wat, dtzm, errmsg, errflg & + & tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & & ) use machine , only : kind_phys @@ -797,7 +797,7 @@ subroutine sfc_nst_post_run & integer, parameter :: r8 = kind_phys ! --- inputs: - integer, intent(in) :: im + integer, intent(in) :: im, nthreads logical, dimension(im), intent(in) :: wet, icy real (kind=kind_phys), intent(in) :: rlapse, tgice real (kind=kind_phys), dimension(im), intent(in) :: oro, oro_uf @@ -840,7 +840,7 @@ subroutine sfc_nst_post_run & zsea1 = 0.001_r8*real(nstf_name4) zsea2 = 0.001_r8*real(nstf_name5) call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, & - & im, 1, dtzm) + & im, 1, nthreads, dtzm) do i = 1, im ! if (wet(i) .and. .not.icy(i)) then ! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 4198af0eb..ed0451aaa 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -768,6 +768,14 @@ kind = kind_phys intent = in optional = F +[nthreads] + standard_name = omp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -956,6 +964,14 @@ kind = kind_phys intent = inout optional = F +[nthreads] + standard_name = omp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in + optional = F [dtzm] standard_name = mean_change_over_depth_in_sea_water_temperature long_name = mean of dT(z) (zsea1 to zsea2) From ddcc4b84e5059dd2dbf8be65f334bbcc631ad410 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 29 Jul 2020 19:18:53 +0000 Subject: [PATCH 29/30] fixing a typo in ugwp_driver_v0.F --- physics/ugwp_driver_v0.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index abba5137f..f209cf97a 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -138,7 +138,7 @@ subroutine cires_ugwp_driver_v0(me, master, pkdis(i,k) = zero enddo enddo - if (cdmbgwd(1) > zero.or. cdmbgwd(2) > zero)_r8 then + if (cdmbgwd(1) > zero.or. cdmbgwd(2) > zero) then call gwdps(im, im, im, levs, Pdvdt, Pdudt, Pdtdt & &, ugrs, vgrs, tgrs, qgrs & &, kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt& From e530096764773b67fa30c7f3b11285c81bb5374d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 30 Jul 2020 17:39:57 +0000 Subject: [PATCH 30/30] fixing one file --- physics/ugwp_driver_v0.F | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index f209cf97a..f573c8776 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -38,7 +38,7 @@ subroutine cires_ugwp_driver_v0(me, master, implicit none !input - integer, parameter :: r8 = kind_phys + integer, parameter :: kp = kind_phys integer, intent(in) :: me, master integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr @@ -89,9 +89,9 @@ subroutine cires_ugwp_driver_v0(me, master, ! ! switches that activate impact of OGWs and NGWs along with eddy diffusion ! - real(kind=kind_phys), parameter :: pogw=1.0_r8, pngw=1.0_r8 - &, pked=1.0_r8, zero=0.0_r8 - &, ompked=1.0_r8-pked + real(kind=kind_phys), parameter :: pogw=1.0_kp, pngw=1.0_kp + &, pked=1.0_kp, zero=0.0_kp + &, ompked=1.0_kp-pked ! ! switches for GW-effects: pogw=1 (OGWs) pngw=1 (NGWs) pked=1 (eddy mixing) ! @@ -162,7 +162,7 @@ subroutine cires_ugwp_driver_v0(me, master, ! call slat_geos5(im, xlatd, tau_ngw) ! - if (abs(1.0_r8-cdmbgwd(3)) > 1.0e-6_r8) then + if (abs(1.0_kp-cdmbgwd(3)) > 1.0e-6_kp) then if (cdmbgwd(4) > zero) then do i=1,im turb_fac(i) = zero @@ -182,7 +182,7 @@ subroutine cires_ugwp_driver_v0(me, master, rfac = 86400000 / dtp do i=1,im tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) - tau_ngw(i) = tau_ngw(i) * max(0.1_r8, min(5.0_r8, tx1)) + tau_ngw(i) = tau_ngw(i) * max(0.1_kp, min(5.0_kp, tx1)) enddo endif do i=1,im @@ -317,7 +317,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, use sso_coorde, only : pgwd, pgwd4, debugprint !---------------------------------------- implicit none - integer, parameter :: r8 = kind_phys + integer, parameter :: kp = kind_phys character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' integer, intent(in) :: im, km, imx, kdt integer, intent(in) :: me, master @@ -363,9 +363,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! cleff = 2.5*0.5e-5 * sqrt(192./768.) => Lh_eff = 1004. km ! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective !--------------------------------------------------------------------- - real(kind=kind_phys) :: gammin = 0.00999999_r8 - real(kind=kind_phys), parameter :: nhilmax = 25.0_r8 - real(kind=kind_phys), parameter :: sso_min = 3000.0_r8 + real(kind=kind_phys) :: gammin = 0.00999999_kp + real(kind=kind_phys), parameter :: nhilmax = 25.0_kp + real(kind=kind_phys), parameter :: sso_min = 3000.0_kp logical, parameter :: do_adjoro = .true. ! real(kind=kind_phys) :: shilmin, sgrmax, sgrmin @@ -439,7 +439,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) dxres = pi2*arad/float(IMX) - hdxres = 0.5_r8*dxres + hdxres = 0.5_kp*dxres ! shilmin = sgrmin/nhilmax ! not used - Moorthi ! gammin = min(sso_min/dsmax, 1.) ! Moorthi - with this results are not reproducible @@ -1311,7 +1311,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, implicit none !23456 - integer, parameter :: r8 = kind_phys + integer, parameter :: kp = kind_phys integer, intent(in) :: klev ! vertical level integer, intent(in) :: klon ! horiz tiles @@ -1338,9 +1338,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, 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_r8 ! - real, parameter :: epsln = 1.0e-12_r8 ! - real, parameter :: zero = 0.0_r8, one = 1.0_r8, half = 0.5_r8 + real, parameter :: minvel = 0.5_kp ! + real, parameter :: epsln = 1.0e-12_kp ! + real, parameter :: zero = 0.0_kp, one = 1.0_kp, half = 0.5_kp !vay-2018 @@ -1466,7 +1466,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, tvc1 = tm1(jl,jk) * (one +fv*qm1(jl,jk)) tvm1 = tm1(jl,jk-1) * (one +fv*qm1(jl,jk-1)) ! zthm1(jl,jk) = 0.5 *(tvc1+tvm1) - zthm1 = 2.0_r8 / (tvc1+tvm1) + zthm1 = 2.0_kp / (tvc1+tvm1) zuhm1(jl,jk) = half *(um1(jl,jk-1)+um1(jl,jk)) zvhm1(jl,jk) = half *(vm1(jl,jk-1)+vm1(jl,jk)) ! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) @@ -1475,7 +1475,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, v_zmet(jl,jk) = zdelp + zdelp delpi(jl,jk) = grav / (prsi(jl,jk-1) - prsi(jl,jk)) vueff(jl,jk) = - & 2.e-5_r8*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min + & 2.e-5_kp*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min ! ! zbn2(jl,jk) = grav2cpd/zthm1(jl,jk) zbn2(jl,jk) = grav2cpd*zthm1