diff --git a/ccpp/physics b/ccpp/physics index fd886e3ce..b6ecca78a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit fd886e3ce336c1dfc7e4729ce7c267f8d1f063a4 +Subproject commit b6ecca78a1d321bb290931c1a395c9f7ff93e3f7 diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index 8b5859a93..953e97f4c 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -7,7 +7,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) GFS_sfcprop_type, GFS_cldprop_type implicit none - integer, intent(in) :: nblks + integer :: nblks type(GFS_control_type), intent(in) :: Model type(GFS_grid_type), intent(in) :: Grid(nblks) type(GFS_sfcprop_type), intent(inout) :: Sfcprop(nblks) @@ -33,7 +33,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) TG3FCS (Model%nx*Model%ny), & CNPFCS (Model%nx*Model%ny), & AISFCS (Model%nx*Model%ny), & -! F10MFCS(Model%nx*Model%ny), & + F10MFCS(Model%nx*Model%ny), & VEGFCS (Model%nx*Model%ny), & VETFCS (Model%nx*Model%ny), & SOTFCS (Model%nx*Model%ny), & @@ -54,8 +54,6 @@ 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 @@ -104,7 +102,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) ZORFCS (len) = Sfcprop(nb)%zorl (ix) TG3FCS (len) = Sfcprop(nb)%tg3 (ix) CNPFCS (len) = Sfcprop(nb)%canopy (ix) -! F10MFCS (len) = Sfcprop(nb)%f10m (ix) + F10MFCS (len) = Sfcprop(nb)%f10m (ix) VEGFCS (len) = Sfcprop(nb)%vfrac (ix) VETFCS (len) = Sfcprop(nb)%vtype (ix) SOTFCS (len) = Sfcprop(nb)%stype (ix) @@ -145,11 +143,6 @@ 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) @@ -184,7 +177,6 @@ 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 @@ -197,10 +189,10 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) len = len + 1 Sfcprop(nb)%slmsk (ix) = SLIFCS (len) if ( Model%nstf_name(1) > 0 ) then - Sfcprop(nb)%tref(ix) = TSFFCS (len) -! if ( Model%nstf_name(2) == 0 ) then + Sfcprop(nb)%tref(ix) = TSFFCS (len) +! if (Model%nstf_name(2) == 0) then ! dt_warm = (Sfcprop(nb)%xt(ix) + Sfcprop(nb)%xt(ix) ) & -! / Sfcprop(nb)%xz(ix) +! / Sfcprop(nb)%xz(ix) ! Sfcprop(nb)%tsfco(ix) = Sfcprop(nb)%tref(ix) & ! + dt_warm - Sfcprop(nb)%dt_cool(ix) ! endif @@ -212,7 +204,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%zorl (ix) = ZORFCS (len) Sfcprop(nb)%tg3 (ix) = TG3FCS (len) Sfcprop(nb)%canopy (ix) = CNPFCS (len) -! Sfcprop(nb)%f10m (ix) = F10MFCS (len) + Sfcprop(nb)%f10m (ix) = F10MFCS (len) Sfcprop(nb)%vfrac (ix) = VEGFCS (len) Sfcprop(nb)%vtype (ix) = VETFCS (len) Sfcprop(nb)%stype (ix) = SOTFCS (len) diff --git a/gfsphysics/physics/sfcsub.F b/gfsphysics/physics/sfcsub.F index 58c387f29..964f90eaa 100644 --- a/gfsphysics/physics/sfcsub.F +++ b/gfsphysics/physics/sfcsub.F @@ -28,107 +28,103 @@ module sfccyc_module integer :: soil_type_landice ! end module sfccyc_module - subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & - &, iy,im,id,ih,fh & - &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl & - &, sihfcs,sicfcs,sitfcs & - &, swdfcs,slcfcs & - &, vmnfcs,vmxfcs,slpfcs,absfcs & - &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & - &, vegfcs,vetfcs,sotfcs,alffcs & - &, cvfcs,cvbfcs,cvtfcs,me,nlunit & - &, sz_nml,input_nml_file & - &, lake, min_lakeice, min_seaice & + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc + &, iy,im,id,ih,fh + &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl + &, sihfcs,sicfcs,sitfcs + &, swdfcs,slcfcs + &, vmnfcs,vmxfcs,slpfcs,absfcs + &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs + &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs + &, vegfcs,vetfcs,sotfcs,alffcs + &, cvfcs,cvbfcs,cvtfcs,me,nlunit + &, sz_nml,input_nml_file &, 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, intent(in) :: use_ufo, nst_anl - logical, intent(in) :: lake(len) - real (kind=kind_io8), intent(in) :: min_lakeice, min_seaice - - real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, & - & orolmx,orolmn,oroomx,oroomn,orosmx, & - & orosmn,oroimx,oroimn,orojmx,orojmn, & - & alblmx,alblmn,albomx,albomn,albsmx, & - & albsmn,albimx,albimn,albjmx,albjmn, & - & wetlmx,wetlmn,wetomx,wetomn,wetsmx, & - & wetsmn,wetimx,wetimn,wetjmx,wetjmn, & - & snolmx,snolmn,snoomx,snoomn,snosmx, & - & snosmn,snoimx,snoimn,snojmx,snojmn, & - & zorlmx,zorlmn,zoromx,zoromn,zorsmx, & - & zorsmn,zorimx,zorimn,zorjmx,zorjmn, & - & plrlmx,plrlmn,plromx,plromn,plrsmx, & - & plrsmn,plrimx,plrimn,plrjmx,plrjmn, & - & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, & - & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, & - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, & - & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, & - & stclmx,stclmn,stcomx,stcomn,stcsmx, & - & stcsmn,stcimx,stcimn,stcjmx,stcjmn, & - & smclmx,smclmn,smcomx,smcomn,smcsmx, & - & smcsmn,smcimx,smcimn,smcjmx,smcjmn, & - & scvlmx,scvlmn,scvomx,scvomn,scvsmx, & - & scvsmn,scvimx,scvimn,scvjmx,scvjmn, & - & veglmx,veglmn,vegomx,vegomn,vegsmx, & - & vegsmn,vegimx,vegimn,vegjmx,vegjmn, & - & vetlmx,vetlmn,vetomx,vetomn,vetsmx, & - & vetsmn,vetimx,vetimn,vetjmx,vetjmn, & - & sotlmx,sotlmn,sotomx,sotomn,sotsmx, & - & sotsmn,sotimx,sotimn,sotjmx,sotjmn, & - & alslmx,alslmn,alsomx,alsomn,alssmx, & - & alssmn,alsimx,alsimn,alsjmx,alsjmn, & - & epstsf,epsalb,epssno,epswet,epszor, & - & epsplr,epsoro,epssmc,epsscv,eptsfc, & - & epstg3,epsais,epsacn,epsveg,epsvet, & - & epssot,epsalf,qctsfs,qcsnos,qctsfi, & - & aislim,snwmin,snwmax,cplrl,cplrs, & - & cvegl,czors,csnol,csnos,czorl,csots, & - & csotl,cvwgs,cvetl,cvets,calfs, & - & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, & - & calbl,calfl,calbs,ctsfs,grboro, & - & grbmsk,ctsfl,deltf,caisl,caiss, & - & fsalfl,fsalfs,flalfs,falbl,ftsfl, & - & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, & - & faiss,fsnol,bltmsk,falbs,cvegs,percrit, & - & deltsfc,critp2,critp3,blnmsk,critp1, & - & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, & - & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, & - & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, & - & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 & - &, fsihl,fsihs,fsicl,fsics, & - & csihl,csihs,csicl,csics,epssih,epssic & - &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, & - & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, & - & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, & - & epsslp,epsabs & - &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, & - & sihsmn,sihimx,sihimn,sihjmx,sihjmn, & - & siclmx,siclmn,sicomx,sicomn,sicsmx, & - & sicsmn,sicimx,sicimn,sicjmx,sicjmn & - &, glacir_hice & - &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, & - & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, & - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, & - & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, & - & slplmx,slplmn,slpomx,slpomn,slpsmx, & - & slpsmn,slpimx,slpimn,slpjmx,slpjmn, & - & abslmx,abslmn,absomx,absomn,abssmx, & - & abssmn,absimx,absimn,absjmx,absjmn & + character(len=*), intent(in) :: tile_num_ch + integer,intent(in) :: i_index(len), j_index(len) + logical use_ufo, nst_anl + real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, + & orolmx,orolmn,oroomx,oroomn,orosmx, + & orosmn,oroimx,oroimn,orojmx,orojmn, + & alblmx,alblmn,albomx,albomn,albsmx, + & albsmn,albimx,albimn,albjmx,albjmn, + & wetlmx,wetlmn,wetomx,wetomn,wetsmx, + & wetsmn,wetimx,wetimn,wetjmx,wetjmn, + & snolmx,snolmn,snoomx,snoomn,snosmx, + & snosmn,snoimx,snoimn,snojmx,snojmn, + & zorlmx,zorlmn,zoromx,zoromn,zorsmx, + & zorsmn,zorimx,zorimn,zorjmx, zorjmn, + & plrlmx,plrlmn,plromx,plromn,plrsmx, + & plrsmn,plrimx,plrimn,plrjmx,plrjmn, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, + & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, + & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, + & stclmx,stclmn,stcomx,stcomn,stcsmx, + & stcsmn,stcimx,stcimn,stcjmx,stcjmn, + & smclmx,smclmn,smcomx,smcomn,smcsmx, + & smcsmn,smcimx,smcimn,smcjmx,smcjmn, + & scvlmx,scvlmn,scvomx,scvomn,scvsmx, + & scvsmn,scvimx,scvimn,scvjmx,scvjmn, + & veglmx,veglmn,vegomx,vegomn,vegsmx, + & vegsmn,vegimx,vegimn,vegjmx,vegjmn, + & vetlmx,vetlmn,vetomx,vetomn,vetsmx, + & vetsmn,vetimx,vetimn,vetjmx,vetjmn, + & sotlmx,sotlmn,sotomx,sotomn,sotsmx, + & sotsmn,sotimx,sotimn,sotjmx,sotjmn, + & alslmx,alslmn,alsomx,alsomn,alssmx, + & alssmn,alsimx,alsimn,alsjmx,alsjmn, + & epstsf,epsalb,epssno,epswet,epszor, + & epsplr,epsoro,epssmc,epsscv,eptsfc, + & epstg3,epsais,epsacn,epsveg,epsvet, + & epssot,epsalf,qctsfs,qcsnos,qctsfi, + & aislim,snwmin,snwmax,cplrl,cplrs, + & cvegl,czors,csnol,csnos,czorl,csots, + & csotl,cvwgs,cvetl,cvets,calfs, + & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, + & calbl,calfl,calbs,ctsfs,grboro, + & grbmsk,ctsfl,deltf,caisl,caiss, + & fsalfl,fsalfs,flalfs,falbl,ftsfl, + & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, + & faiss,fsnol,bltmsk,falbs,cvegs,percrit, + & deltsfc,critp2,critp3,blnmsk,critp1, + & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, + & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, + & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, + & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 + &, fsihl,fsihs,fsicl,fsics, + & csihl,csihs,csicl,csics,epssih,epssic + &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, + & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, + & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, + & epsslp,epsabs + &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, + & sihsmn,sihimx,sihimn,sihjmx,sihjmn, + & siclmx,siclmn,sicomx,sicomn,sicsmx, + & sicsmn,sicimx,sicimn,sicjmx,sicjmn + &, glacir_hice + &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, + & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, + & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, + & slplmx,slplmn,slpomx,slpomn,slpsmx, + & slpsmn,slpimx,slpimn,slpjmx,slpjmn, + & abslmx,abslmn,absomx,absomn,abssmx, + & abssmn,absimx,absimn,absjmx,absjmn &, sihnew - integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, & - & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, & - & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, & - & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, & - & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, & - & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb & + integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, + & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, + & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, + & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, + & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, + & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc - logical gausm, deads, qcmsk, znlst, monclm, monanl, & + logical gausm, deads, qcmsk, znlst, monclm, monanl, & monfcs, monmer, mondif, landice character(len=*), intent(in) :: input_nml_file(sz_nml) @@ -269,9 +265,8 @@ 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,sicjmx=1.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,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, @@ -420,7 +415,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! mask orography and variance on gaussian grid ! - real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) & + real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) &, orogd(len) real (kind=kind_io8) rla(len), rlo(len) ! @@ -433,50 +428,50 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! climatology surface fields (last character 'c' or 'clm' indicate climatology) ! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc & - &, fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc & - &, fnvegc,fnvetc,fnsotc & + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, + & fnvegc,fnvetc,fnsotc &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 - real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len) & - &, zorclm(len), albclm(len,4), aisclm(len) & - &, tg3clm(len), acnclm(len), cnpclm(len) & - &, cvclm (len), cvbclm(len), cvtclm(len) & - &, scvclm(len), tsfcl2(len), vegclm(len) & - &, vetclm(len), sotclm(len), alfclm(len,2), sliclm(len) & - &, smcclm(len,lsoil), stcclm(len,lsoil) & - &, sihclm(len), sicclm(len) & + real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), + & zorclm(len), albclm(len,4), aisclm(len), + & tg3clm(len), acnclm(len), cnpclm(len), + & cvclm (len), cvbclm(len), cvtclm(len), + & scvclm(len), tsfcl2(len), vegclm(len), + & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), + & smcclm(len,lsoil), stcclm(len,lsoil) + &, sihclm(len), sicclm(len) &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) ! ! analyzed surface fields (last character 'a' or 'anl' indicate analysis) ! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa & - &, fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna & - &, fnvega,fnveta,fnsota & - &, fnvmna,fnvmxa,fnslpa,fnabsa -! - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len) & - &, zoranl(len), albanl(len,4), aisanl(len) & - &, tg3anl(len), acnanl(len), cnpanl(len) & - &, cvanl (len), cvbanl(len), cvtanl(len) & - &, scvanl(len), tsfan2(len), veganl(len) & - &, vetanl(len), sotanl(len), alfanl(len,2), slianl(len) & - &, smcanl(len,lsoil), stcanl(len,lsoil) & - &, sihanl(len), sicanl(len) & + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, + & fnvega,fnveta,fnsota + &, fnvmna,fnvmxa,fnslpa,fnabsa +! + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & tg3anl(len), acnanl(len), cnpanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & scvanl(len), tsfan2(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), + & smcanl(len,lsoil), stcanl(len,lsoil) + &, sihanl(len), sicanl(len) &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) ! real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0. ! ! predicted surface fields (last characters 'fcs' indicates forecast) ! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len) & - &, zorfcs(len), albfcs(len,4), aisfcs(len) & - &, tg3fcs(len), acnfcs(len), cnpfcs(len) & - &, cvfcs (len), cvbfcs(len), cvtfcs(len) & - &, slifcs(len), vegfcs(len) & - &, vetfcs(len), sotfcs(len), alffcs(len,2) & - &, smcfcs(len,lsoil), stcfcs(len,lsoil) & - &, sihfcs(len), sicfcs(len), sitfcs(len) & - &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) & + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), + & zorfcs(len), albfcs(len,4), aisfcs(len), + & tg3fcs(len), acnfcs(len), cnpfcs(len), + & cvfcs (len), cvbfcs(len), cvtfcs(len), + & slifcs(len), vegfcs(len), + & vetfcs(len), sotfcs(len), alffcs(len,2), + & smcfcs(len,lsoil), stcfcs(len,lsoil) + &, sihfcs(len), sicfcs(len), sitfcs(len) + &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) &, swdfcs(len), slcfcs(len,lsoil) ! ! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched @@ -558,7 +553,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, lprnt + logical ldebug,lqcbgs + logical lprnt ! ! debug only ! @@ -745,7 +741,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & lprnt = .false. iprnt = 1 ! do i=1,len -! if (ifp == 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i) +! if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i) ! *,' rlo=',rlo(i) ! tem1 = abs(rla(i) - 48.75) ! tem2 = abs(rlo(i) - (-68.50)) @@ -779,7 +775,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & abslmn = .01 abssmn = .01 endif - if (ifp == 0) then + if(ifp.eq.0) then ifp = 1 do k=1,lsoil fsmcl(k) = 99999. @@ -796,15 +792,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & #endif ! write(6,namsfc) ! - 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) + 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) print *,' aislim=',aislim,' sihnew=',sihnew print *,' isot=', isot,' ivegsrc=',ivegsrc endif @@ -822,176 +818,176 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! deltf = deltsfc / 24.0 ! - ctsfl = 0. !... tsfc over land - if (ftsfl >= 99999.) ctsfl = 1. - if (ftsfl > 0. .and. ftsfl < 99999) ctsfl = exp(-deltf/ftsfl) + ctsfl=0. !... tsfc over land + if(ftsfl.ge.99999.) ctsfl=1. + if((ftsfl.gt.0.).and.(ftsfl.lt.99999)) ctsfl=exp(-deltf/ftsfl) ! ctsfs=0. !... tsfc over sea - if (ftsfs >= 99999.) ctsfs=1. - if (ftsfs > 0. .and. ftsfs < 99999) ctsfs = exp(-deltf/ftsfs) + if(ftsfs.ge.99999.) ctsfs=1. + if((ftsfs.gt.0.).and.(ftsfs.lt.99999)) ctsfs=exp(-deltf/ftsfs) ! do k=1,lsoil - 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)) + 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)) csmcs(k)=0. !... soilm over sea - if (fsmcs(k) >= 99999.) csmcs(k) = 1. - if (fsmcs(k) > 0. .and. fsmcs(k) < 99999) - & csmcs(k) = exp(-deltf/fsmcs(k)) + if(fsmcs(k).ge.99999.) csmcs(k)=1. + if((fsmcs(k).gt.0.).and.(fsmcs(k).lt.99999)) + & csmcs(k)=exp(-deltf/fsmcs(k)) enddo ! - calbl = 0. !... albedo over land - if (falbl >= 99999.) calbl = 1. - if (falbl > 0. .and. falbl < 99999) calbl = exp(-deltf/falbl) + calbl=0. !... albedo over land + if(falbl.ge.99999.) calbl=1. + if((falbl.gt.0.).and.(falbl.lt.99999)) calbl=exp(-deltf/falbl) ! calfl=0. !... fraction field for albedo over land - if (falfl >= 99999.) calfl = 1. - if (falfl > 0. .and. falfl < 99999) calfl = exp(-deltf/falfl) + if(falfl.ge.99999.) calfl=1. + if((falfl.gt.0.).and.(falfl.lt.99999)) calfl=exp(-deltf/falfl) ! calbs=0. !... albedo over sea - if (falbs >= 99999.) calbs = 1. - if (falbs > 0. .and. falbs < 99999) calbs = exp(-deltf/falbs) + if(falbs.ge.99999.) calbs=1. + if((falbs.gt.0.).and.(falbs.lt.99999)) calbs=exp(-deltf/falbs) ! - calfs = 0. !... fraction field for albedo over sea - if (falfs >= 99999.) calfs = 1. - if (falfs > 0. .and. falfs < 99999) calfs = exp(-deltf/falfs) + 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) ! - caisl = 0. !... sea ice over land - if (faisl >= 99999.) caisl = 1. - if (faisl > 0. .and. faisl < 99999) caisl = 1. + caisl=0. !... sea ice over land + if(faisl.ge.99999.) caisl=1. + if((faisl.gt.0.).and.(faisl.lt.99999)) caisl=1. ! - caiss = 0. !... sea ice over sea - if (faiss >= 99999.) caiss = 1. - if (faiss > 0. .and. faiss < 99999) caiss = 1. + caiss=0. !... sea ice over sea + if(faiss.ge.99999.) caiss=1. + if((faiss.gt.0.).and.(faiss.lt.99999)) caiss=1. ! - csnol = 0. !... snow over land - if (fsnol >= 99999.) csnol = 1. - if (fsnol > 0. .and. fsnol < 99999) csnol = exp(-deltf/fsnol) + csnol=0. !... snow over land + if(fsnol.ge.99999.) csnol=1. + if((fsnol.gt.0.).and.(fsnol.lt.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 < 0.) csnol = fsnol + if(fsnol.lt.0.)csnol=fsnol ! - csnos = 0. !... snow over sea - if (fsnos >= 99999.) csnos = 1. - if (fsnos > 0 .and. fsnos < 99999) csnos = exp(-deltf/fsnos) + csnos=0. !... snow over sea + if(fsnos.ge.99999.) csnos=1. + if((fsnos.gt.0.).and.(fsnos.lt.99999)) csnos=exp(-deltf/fsnos) ! - czorl = 0. !... roughness length over land - if (fzorl >= 99999.) czorl = 1. - if (fzorl > 0. .and. fzorl < 99999) czorl = exp(-deltf/fzorl) + czorl=0. !... roughness length over land + if(fzorl.ge.99999.) czorl=1. + if((fzorl.gt.0.).and.(fzorl.lt.99999)) czorl=exp(-deltf/fzorl) ! - czors = 0. !... roughness length over sea - if (fzors >= 99999.) czors = 1. - if (fzors > 0. .and. fzors < 99999) czors = exp(-deltf/fzors) + czors=0. !... roughness length over sea + if(fzors.ge.99999.) czors=1. + if((fzors.gt.0.).and.(fzors.lt.99999)) czors=exp(-deltf/fzors) ! -! cplrl = 0. !... plant resistance over land -! if (fplrl >= 99999.) cplrl = 1. -! if (fplrl > 0. .and. fplrl < 99999) cplrl=exp(-deltf/fplrl) +! cplrl=0. !... plant resistance over land +! if(fplrl.ge.99999.) cplrl=1. +! if((fplrl.gt.0.).and.(fplrl.lt.99999)) cplrl=exp(-deltf/fplrl) ! -! cplrs = 0. !... plant resistance over sea -! if (fplrs >= 99999.) cplrs = 1. -! if (fplrs > 0. .and. fplrs < 99999) cplrs=exp(-deltf/fplrs) +! cplrs=0. !... plant resistance over sea +! if(fplrs.ge.99999.) cplrs=1. +! if((fplrs.gt.0.).and.(fplrs.lt.99999)) cplrs=exp(-deltf/fplrs) ! do k=1,lsoil - 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)) + 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)) enddo ! - cvegl = 0. !... vegetation fraction over land - if (fvegl >= 99999.) cvegl = 1. - if (fvegl > 0. .and. fvegl < 99999) cvegl = exp(-deltf/fvegl) + cvegl=0. !... vegetation fraction over land + if(fvegl.ge.99999.) cvegl=1. + if((fvegl.gt.0.).and.(fvegl.lt.99999)) cvegl=exp(-deltf/fvegl) ! - cvegs = 0. !... vegetation fraction over sea - if (fvegs >= 99999.) cvegs = 1. - if (fvegs > 0. .and. fvegs < 99999) cvegs = exp(-deltf/fvegs) + cvegs=0. !... vegetation fraction over sea + if(fvegs.ge.99999.) cvegs=1. + if((fvegs.gt.0.).and.(fvegs.lt.99999)) cvegs=exp(-deltf/fvegs) ! - cvetl = 0. !... vegetation type over land - if (fvetl >= 99999.) cvetl = 1. - if (fvetl > 0. .and. fvetl < 99999) cvetl = exp(-deltf/fvetl) + cvetl=0. !... vegetation type over land + if(fvetl.ge.99999.) cvetl=1. + if((fvetl.gt.0.).and.(fvetl.lt.99999)) cvetl=exp(-deltf/fvetl) ! - cvets = 0. !... vegetation type over sea - if (fvets >= 99999.) cvets = 1. - if (fvets > 0. .and. fvets < 99999) cvets = exp(-deltf/fvets) + cvets=0. !... vegetation type over sea + if(fvets.ge.99999.) cvets=1. + if((fvets.gt.0.).and.(fvets.lt.99999)) cvets=exp(-deltf/fvets) ! - csotl = 0. !... soil type over land - if (fsotl >= 99999.) csotl = 1. - if (fsotl > 0. .and. fsotl < 99999) csotl = exp(-deltf/fsotl) + csotl=0. !... soil type over land + if(fsotl.ge.99999.) csotl=1. + if((fsotl.gt.0.).and.(fsotl.lt.99999)) csotl=exp(-deltf/fsotl) ! - csots = 0. !... soil type over sea - if (fsots >= 99999.) csots = 1. - if (fsots > 0. .and. fsots < 99999) csots = exp(-deltf/fsots) + csots=0. !... soil type over sea + if(fsots.ge.99999.) csots=1. + if((fsots.gt.0.).and.(fsots.lt.99999)) csots=exp(-deltf/fsots) !cwu [+16l]--------------------------------------------------------------- ! - csihl = 0. !... sea ice thickness over land - if (fsihl >= 99999.) csihl = 1. - if (fsihl > 0. .and. fsihl < 99999) csihl = exp(-deltf/fsihl) + 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) ! - csihs = 0. !... sea ice thickness over sea - if (fsihs >= 99999.) csihs = 1. - if (fsihs > 0. .and. fsihs < 99999) csihs = exp(-deltf/fsihs) + 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) ! - csicl = 0. !... sea ice concentration over land - if (fsicl >= 99999.) csicl = 1. - if (fsicl > 0. .and. fsicl < 99999) csicl = exp(-deltf/fsicl) + 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) ! - csics = 0. !... sea ice concentration over sea - if (fsics >= 99999.) csics = 1. - if (fsics > 0. .and. fsics < 99999) csics = exp(-deltf/fsics) + 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) !clu [+32l]--------------------------------------------------------------- ! - cvmnl = 0. !... min veg cover over land - if (fvmnl >= 99999.) cvmnl = 1. - if (fvmnl > 0. .and. fvmnl < 99999) cvmnl = exp(-deltf/fvmnl) + 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) ! - cvmns = 0. !... min veg cover over sea - if (fvmns >= 99999.) cvmns = 1. - if (fvmns > 0. .and. fvmns < 99999) cvmns = exp(-deltf/fvmns) + 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) ! - cvmxl = 0. !... max veg cover over land - if (fvmxl >= 99999.) cvmxl = 1. - if (fvmxl > 0. .and. fvmxl < 99999) cvmxl = exp(-deltf/fvmxl) + 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) ! - cvmxs = 0. !... max veg cover over sea - if (fvmxs >= 99999.) cvmxs = 1. - if (fvmxs > 0. .and. fvmxs < 99999) cvmxs = exp(-deltf/fvmxs) + 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) ! - cslpl = 0. !... slope type over land - if (fslpl >= 99999.) cslpl = 1. - if (fslpl > 0. .and. fslpl < 99999) cslpl = exp(-deltf/fslpl) + cslpl=0. !... slope type over land + if(fslpl.ge.99999.) cslpl=1. + if((fslpl.gt.0.).and.(fslpl.lt.99999)) cslpl=exp(-deltf/fslpl) ! - cslps = 0. !... slope type over sea - if (fslps >= 99999.) cslps = 1. - if (fslps > 0. .and. fslps < 99999) cslps = exp(-deltf/fslps) + cslps=0. !... slope type over sea + if(fslps.ge.99999.) cslps=1. + if((fslps.gt.0.).and.(fslps.lt.99999)) cslps=exp(-deltf/fslps) ! - cabsl = 0. !... snow albedo over land - if (fabsl >= 99999.) cabsl = 1. - if (fabsl > 0. .and. fabsl < 99999) cabsl = exp(-deltf/fabsl) + cabsl=0. !... snow albedo over land + if(fabsl.ge.99999.) cabsl=1. + if((fabsl.gt.0.).and.(fabsl.lt.99999)) cabsl=exp(-deltf/fabsl) ! - cabss = 0. !... snow albedo over sea - if (fabss >= 99999.) cabss = 1. - if (fabss > 0. .and. fabss < 99999) cabss = exp(-deltf/fabss) + cabss=0. !... snow albedo over sea + if(fabss.ge.99999.) cabss=1. + if((fabss.gt.0.).and.(fabss.lt.99999)) cabss=exp(-deltf/fabss) !clu ---------------------------------------------------------------------- ! ! 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 == 0) then + if (me .eq. 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 @@ -1042,7 +1038,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! read climatology fields ! - if (me == 0) then + if (me .eq. 0) then write(6,*) '==============' write(6,*) 'climatology' write(6,*) '==============' @@ -1099,35 +1095,32 @@ 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) /= ' ') then + if(fnaisc(1:8).ne.' ') then !cwu [+5l/-1l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*aisclm(i) sicclm(i) = aisclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicclm(i) /= 1.0) then + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicclm(i).ne.1.) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo crit=aislim !* crit=0.5 -! call rof01(aisclm,len,'ge',crit) - call rof01_len(aisclm, len, 'ge', lake, min_lakeice, min_seaice) - - elseif(fnacnc(1:8) /= ' ') then + call rof01(aisclm,len,'ge',crit) + elseif(fnacnc(1:8).ne.' ') then !cwu [+4l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*acnclm(i) sicclm(i) = acnclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicclm(i).ne.1.) then + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicclm(i).ne.1.) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo -! call rof01(acnclm,len,'ge',aislim) - call rof01_len(acnclm, len, 'ge', lake, min_lakeice, min_seaice) + call rof01(acnclm,len,'ge',aislim) do i=1,len aisclm(i) = acnclm(i) enddo @@ -1141,7 +1134,6 @@ 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) ! @@ -1159,7 +1151,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, @@ -1170,7 +1162,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! get snow cover from snow depth array ! - if(fnscvc(1:8) == ' ') then + if(fnscvc(1:8).eq.' ') then call getscv(snoclm,scvclm,len) endif ! @@ -1183,7 +1175,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! quality control ! do i=1,len - icefl2(i) = sicclm(i) > 0.99999 + icefl2(i) = sicclm(i) .gt. 0.99999 enddo kqcm=1 call qcmxmn('tsfc ',tsfclm,sliclm,snoclm,icefl2, @@ -1223,7 +1215,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! get soil temp and moisture (after all the qcs are completed) ! - if(fnsmcc(1:8) == ' ') then + if(fnsmcc(1:8).eq.' ') then call getsmc(wetclm,len,lsoil,smcclm,me) endif call qcmxmn('smc1c ',smcclm(1,1),sliclm,snoclm,icefl1, @@ -1235,17 +1227,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcclm(3:4) - if(lsoil > 2) then - call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if(lsoil.gt.2) then + call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - if (fnstcc(1:8) == ' ') then + if(fnstcc(1:8).eq.' ') then call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) endif call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, @@ -1257,15 +1249,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.gt.2) then + call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1284,10 +1276,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, @@ -1310,7 +1302,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! monitoring prints ! if (monclm) then - if (me == 0) then + if (me .eq. 0) then print *,' ' print *,'monitor of time and space interpolated climatology' print *,' ' @@ -1360,7 +1352,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! ! - if (me == 0) then + if (me .eq. 0) then write(6,*) '==============' write(6,*) ' analysis' write(6,*) '==============' @@ -1384,9 +1376,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) @@ -1394,12 +1386,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 ! @@ -1427,9 +1419,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) @@ -1437,7 +1429,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) @@ -1459,62 +1451,55 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! ice concentration or ice mask (only ice mask used in the model now) ! - if(fnaisa(1:8) /= ' ') then + if(fnaisa(1:8).ne.' ') then !cwu [+5l/-1l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*aisanl(i) sicanl(i) = aisanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicanl(i) /= 1.) then + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicanl(i).ne.1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice endif enddo -! crit=aislim + crit=aislim !* crit=0.5 -! call rof01(aisanl,len,'ge',crit) - call rof01_len(aisanl, len, 'ge', lake, min_lakeice, min_seaice) - elseif(fnacna(1:8) /= ' ') then + call rof01(aisanl,len,'ge',crit) + elseif(fnacna(1:8).ne.' ') then !cwu [+17l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*acnanl(i) sicanl(i) = acnanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicanl(i) /= 1.) then + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicanl(i).ne.1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice endif enddo -! crit=aislim + crit=aislim do i=1,len - 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. + if((slianl(i).eq.0.).and.(sicanl(i).ge.crit)) then + slianl(i)=2. ! print *,'cycle - new ice form: fice=',sicanl(i) - elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then - slianl(i) = 0. + else if((slianl(i).ge.2.).and.(sicanl(i).lt.crit)) then + slianl(i)=0. ! print *,'cycle - ice free: fice=',sicanl(i) - elseif (nint(slianl(i)) == 1 .and. sicanl(i) > crit) then + else if((slianl(i).eq.1.).and.(sicanl(i).ge.sicimn)) then ! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i) = 0. + sicanl(i)=0. endif enddo ! znnt=10. ! call nntprt(acnanl,len,znnt) ! if(lprnt) print *,' acnanl=',acnanl(iprnt) ! do i=1,len -! if (acnanl(i) .gt. 0.3 .and. aisclm(i) == 1.0 +! if (acnanl(i) .gt. 0.3 .and. aisclm(i) .eq. 1.0 ! & .and. aisfcs(i) .ge. 0.75) acnanl(i) = aislim ! enddo ! if(lprnt) print *,' acnanl=',acnanl(iprnt) -! call rof01(acnanl,len,'ge',aislim) - call rof01_len(acnanl, len, 'ge', lake, min_lakeice, min_seaice) + call rof01(acnanl,len,'ge',aislim) do i=1,len - aisanl(i) = acnanl(i) + aisanl(i)=acnanl(i) enddo endif ! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' @@ -1532,7 +1517,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! do k=1,lsoil do i=1,len - if (slianl(i) == 0) then + if (slianl(i) .eq. 0) then smcanl(i,k) = smcomx stcanl(i,k) = tsfanl(i) endif @@ -1547,10 +1532,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 ! @@ -1559,13 +1544,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) /= ' ') then + if(fnsnoa(1:8).ne.' ') 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, @@ -1577,7 +1562,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, @@ -1595,7 +1580,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! do i=1,len - icefl2(i) = sicanl(i) > 0.99999 + icefl2(i) = sicanl(i) .gt. 0.99999 enddo call qcmxmn('tsfa ',tsfanl,slianl,snoanl,icefl2, & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, @@ -1607,7 +1592,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) /= ' ' .or. fnweta(1:8) /= ' ' ) then + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) then call qcmxmn('weta ',wetanl,slianl,snoanl,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, & wetjmx,wetjmn,wetsmx,wetsmn,epswet, @@ -1630,7 +1615,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! get soil temp and moisture ! - if(fnsmca(1:8) == ' ' .and. fnsmcc(1:8) == ' ') then + if(fnsmca(1:8).eq.' ' .and. fnsmcc(1:8).eq.' ') then call getsmc(wetanl,len,lsoil,smcanl,me) endif call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, @@ -1642,17 +1627,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcanl(3:4) - if (lsoil > 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.gt.2) then + call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - if(fnstca(1:8) == ' ') then + if(fnstca(1:8).eq.' ') then call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) endif call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, @@ -1664,15 +1649,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.gt.2) then + call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1708,7 +1693,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! monitoring prints ! if (monanl) then - if (me == 0) then + if (me .eq. 0) then print *,' ' print *,'monitor of time and space interpolated analysis' print *,' ' @@ -1757,20 +1742,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! read in forecast fields if needed ! - if (me == 0) then + if (me .eq. 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 == 0) write(6,*) 'this run is dead start run' + if (me .eq. 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, @@ -1788,13 +1773,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) /= 0.) then + if(sig1t(1).ne.0.) then call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, & tsfimx) do i=1,len - icefl2(i) = sicfcs(i) > 0.99999 + icefl2(i) = sicfcs(i) .gt. 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, @@ -1809,7 +1794,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 @@ -1837,23 +1822,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) /= 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) .ne. 0.) then + swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) + else + swratio(i,j) = -999. + endif + enddo enddo !clu ----------------------------------------------------------------------- ! - if (lqcbgs .and. irtacn == 0) then + if(lqcbgs .and. irtacn .eq. 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, @@ -1868,7 +1853,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) /= ' ' .or. fnweta(1:8) /= ' ' ) + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) & then call qcmxmn('wetf ',wetfcs,slifcs,snofcs,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, @@ -1894,10 +1879,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, @@ -1907,15 +1892,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 > 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.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) endif call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, @@ -1926,15 +1911,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 > 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.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) endif call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1971,7 +1956,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! if (monfcs) then - if (me == 0) then + if (me .eq. 0) then print *,' ' print *,'monitor of guess' print *,' ' @@ -1986,7 +1971,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 > 2) then + if(lsoil.gt.2) then call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) @@ -2038,14 +2023,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! blend climatology and predicted fields ! - if(me == 0) then + if(me .eq. 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 ! @@ -2099,9 +2084,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call snosfc(snoanl,tsfanl,tsfsmx,len,me) ! do i=1,len - icefl2(i) = sicanl(i) > 0.99999 + icefl2(i) = sicanl(i) .gt. 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, @@ -2116,7 +2101,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & albjmx,albjmn,albsmx,albsmn,epsalb, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ') then + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) + & then call qcmxmn('wetm ',wetanl,slianl,snoanl,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, & wetjmx,wetjmn,wetsmx,wetsmn,epswet, @@ -2141,6 +2127,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, @@ -2149,26 +2146,18 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add 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) +!clu [+8l] add smcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - kqcm = 1 + kqcm=1 call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -2186,10 +2175,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, @@ -2209,7 +2198,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & rla,rlo,len,kqcm,percrit,lgchek,me) ! - if(me == 0) then + if(me .eq. 0) then write(6,*) '==============' write(6,*) 'final results' write(6,*) '==============' @@ -2239,7 +2228,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! check the final merged product ! if (monmer) then - if(me == 0) then + if(me .eq. 0) then print *,' ' print *,'monitor of updated surface fields' print *,' (includes angulation correction)' @@ -2255,13 +2244,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 > 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.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) endif ! if (gaus) then call monitr('cvaanl',cvanl ,slianl,snoanl,len) @@ -2323,7 +2312,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! monitoring prints ! - if(me == 0) then + if(me .eq. 0) then print *,' ' print *,'monitor of difference' print *,' (includes angulation correction)' @@ -2341,11 +2330,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 > 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.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) endif call monitr('tg3dif',tg3fcs,slianl,snoanl,len) call monitr('zordif',zorfcs,slianl,snoanl,len) @@ -2416,21 +2405,15 @@ 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 (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif - if (slifcs(i) >= 2.) then - if (sicfcs(i) > crit) then - tem1 = 1.0 / sicfcs(i) + if (slifcs(i).ge.2.) then + if (sicfcs(i).gt.crit) then 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))*tgice)/sicfcs(i) + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) / sicfcs(i) else tsffcs(i) = tsfanl(i) ! tsffcs(i) = tgice @@ -2440,20 +2423,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & sicfcs(i) = sicanl(i) enddo do i=1,len - if (slifcs(i) < 1.5) then + if (slifcs(i).lt.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 - print *,'warning: check, slifcs and sicfcs', & - & slifcs(i),sicfcs(i) - endif + else if ((slifcs(i).ge.1.5).and.(sicfcs(i).lt.crit)) then + print *,'warning: check, slifcs and sicfcs', + & slifcs(i),sicfcs(i) endif enddo @@ -2462,29 +2438,29 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! do k=1, lsoil fixratio(k) = .false. - if (fsmcl(k) < 99999.) fixratio(k) = .true. + if (fsmcl(k).lt.99999.) fixratio(k) = .true. enddo - if(me == 0) then - print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) + if(me .eq. 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) == -999.) then + if(swratio(i,k) .eq. -999.) then slcfcs(i,k) = smcfcs(i,k) else slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) endif - if (slifcs(i) /= 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. + if (slifcs(i) .ne. 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) == 1.0 .and. + if (slifcs(i) .eq. 1.0 .and. & nint(vetfcs(i)) == veg_type_landice) then do k=1, lsoil slcfcs(i,k) = 1.0 @@ -2495,13 +2471,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! ensure the consistency between snwdph and sheleg ! - 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 + 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 endif ! sea ice model only uses the liquid equivalent depth. @@ -2509,16 +2485,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) /= 1) swdfcs(i) = 3.*snofcs(i) + if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i) enddo do i = 1, len - 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 + 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 endif enddo ! landice mods - impose same minimum snow depth at @@ -2528,7 +2504,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! after adjustment to terrain. if (landice) then do i = 1, len - if (slifcs(i) == 1.0 .and. & + if (slifcs(i) .eq. 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 @@ -2672,7 +2648,7 @@ subroutine dayoyr(iyr,imo,idy,ldy) enddo return end - subroutine hmskrd(lugb,imsk,jmsk,fnmskh, & + subroutine hmskrd(lugb,imsk,jmsk,fnmskh, & kpds5,slmskh,gausm,blnmsk,bltmsk,me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata, xdata, ydata @@ -2705,7 +2681,7 @@ subroutine hmskrd(lugb,imsk,jmsk,fnmskh, & ! return end - subroutine fixrdg(lugb,idim,jdim,fngrib, & + subroutine fixrdg(lugb,idim,jdim,fngrib, & kpds5,gdata,gaus,blno,blto,me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata @@ -2820,7 +2796,8 @@ subroutine fixrdg(lugb,idim,jdim,fngrib, & deallocate(lbms) return end - subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) + subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr + &, me) use machine , only : kind_io8,kind_io4 implicit none integer j,me,kgds11 @@ -3029,16 +3006,16 @@ subroutine subst(data,imax,jmax,dlon,dlat,ijordr) endif return end - subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& - & gauout,len,lmask,rslmsk,slmask & + subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, + & gauout,len,lmask,rslmsk,slmask &, outlat, outlon,me) use machine , only : kind_io8,kind_io4 implicit none - real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, & - & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, & - & wi1j2,wi2j1,rlat,rlon,aphi, & + real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, + & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, + & wi1j2,wi2j1,rlat,rlon,aphi, & rnume,alamd,denom - integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, & + integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, & ii,i1,i2,kmami,it integer nx,kxs,kxt integer, allocatable, save :: imxnx(:) @@ -3046,7 +3023,7 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& ! ! interpolation from lat/lon or gaussian grid to other lat/lon grid ! - real (kind=kind_io8) outlon(len),outlat(len),gauout(len), & + real (kind=kind_io8) outlon(len),outlat(len),gauout(len), & slmask(len) real (kind=kind_io8) regin (imxin,jmxin),rslmsk(imxin,jmxin) ! @@ -3598,46 +3575,54 @@ subroutine maxmin(f,imax,kmax) ! return end - subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & - & aisanl, & - & tg3anl,cvanl ,cvbanl,cvtanl, & - & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, & - & vetanl,sotanl,alfanl, & - & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic - & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, & - & aisclm, & - & tg3clm,cvclm ,cvbclm,cvtclm, & - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, & - & vetclm,sotclm,alfclm, & - & sihclm,sicclm, & !cwu [+1l] add ()clm for sih, sic - & vmnclm,vmxclm,slpclm,absclm, & !clu [+1l] add ()clm for vmn, vmx, slp, abs + subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, + & aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, + & vetanl,sotanl,alfanl, +!cwu [+1l] add ()anl for sih, sic + & sihanl,sicanl, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, + & aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, + & vetclm,sotclm,alfclm, +!cwu [+1l] add ()clm for sih, sic + & sihclm,sicclm, +!clu [+1l] add ()clm for vmn, vmx, slp, abs + & vmnclm,vmxclm,slpclm,absclm, & len,lsoil) use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil ! - real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), & - & snoanl(len), & - & zoranl(len),albanl(len,4),aisanl(len), & - & tg3anl(len), & - & cvanl (len),cvbanl(len),cvtanl(len), & - & cnpanl(len), & - & smcanl(len,lsoil),stcanl(len,lsoil), & - & slianl(len),scvanl(len),veganl(len), & - & vetanl(len),sotanl(len),alfanl(len,2) & - &, sihanl(len),sicanl(len) & - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) - real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), & - & snoclm(len), & - & zorclm(len),albclm(len,4),aisclm(len), & - & tg3clm(len), & - & cvclm (len),cvbclm(len),cvtclm(len), & - & cnpclm(len), & - & smcclm(len,lsoil),stcclm(len,lsoil), & - & sliclm(len),scvclm(len),vegclm(len), & - & vetclm(len),sotclm(len),alfclm(len,2) & - &, sihclm(len),sicclm(len) & + real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), + & snoanl(len), + & zoranl(len),albanl(len,4),aisanl(len), + & tg3anl(len), + & cvanl (len),cvbanl(len),cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len),scvanl(len),veganl(len), + & vetanl(len),sotanl(len),alfanl(len,2) +!cwu [+1l] add ()anl for sih, sic + &, sihanl(len),sicanl(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) + real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), + & snoclm(len), + & zorclm(len),albclm(len,4),aisclm(len), + & tg3clm(len), + & cvclm (len),cvbclm(len),cvtclm(len), + & cnpclm(len), + & smcclm(len,lsoil),stcclm(len,lsoil), + & sliclm(len),scvclm(len),vegclm(len), + & vetclm(len),sotclm(len),alfclm(len,2) +!cwu [+1l] add ()clm for sih, sic + &, sihclm(len),sicclm(len) +!clu [+1l] add ()clm for vmn, vmx, slp, abs &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) ! do i=1,len @@ -3687,34 +3672,43 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & ! return end - subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & - & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,& - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & - & fnveta,fnsota, & - & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, & - & tg3anl,cvanl ,cvbanl,cvtanl, & - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & - & vetanl,sotanl,alfanl,tsfan0, & - & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais,& - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & - & kprvet,kpdsot,kpdalf, & - & kpdvmn,kpdvmx,kpdslp,kpdabs, & !clu [+1l] add kpd() for vmn, vmx, slp, abs - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & !cggg snow mods - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & - & irtvet,irtsot,irtalf & - &, irtvmn,irtvmx,irtslp,irtabs & !clu [+1l] add irt() for vmn, vmx, slp, abs - &, imsk, jmsk, slmskh, outlat, outlon & + subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, + & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnveta,fnsota, +!clu [+1l] add fn()a for vmn, vmx, slp, abs + & fnvmna,fnvmxa,fnslpa,fnabsa, + & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & smcanl,stcanl,slianl,scvanl,acnanl,veganl, + & vetanl,sotanl,alfanl,tsfan0, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, +!cggg snow mods start & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, + & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, +!cggg snow mods end + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kprvet,kpdsot,kpdalf, +!clu [+1l] add kpd() for vmn, vmx, slp, abs + & kpdvmn,kpdvmx,kpdslp,kpdabs, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvet,irtsot,irtalf +!clu [+1l] add irt() for vmn, vmx, slp, abs + &, irtvmn,irtvmx,irtslp,irtabs + &, imsk, jmsk, slmskh, outlat, outlon &, gaus, blno, blto, me, lanom) use machine , only : kind_io8,kind_io4 implicit none logical lanom - integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, & - & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, & - & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy,& - & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, & - & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j & + integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, + & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, +!cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, + & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy, +!cggg snow mods end + & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, + & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j +!clu [+1l] add kpd() and irt() for vmn, vmx, slp, abs &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs real (kind=kind_io8) blto,blno,fh ! @@ -3727,19 +3721,21 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & integer lugi, lskip, lgrib, ndata !cggg snow mods end ! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & fnveta,fnsota +!clu [+1l] add fn()a for vmn, vmx, slp, abs &, fnvmna,fnvmxa,fnslpa,fnabsa - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), & - & zoranl(len), albanl(len,4), aisanl(len), & - & tg3anl(len), acnanl(len), & - & cvanl (len), cvbanl(len), cvtanl(len), & - & slianl(len), scvanl(len), veganl(len), & - & vetanl(len), sotanl(len), alfanl(len,2), & - & smcanl(len,lsoil), stcanl(len,lsoil), & - & tsfan0(len) & + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & tg3anl(len), acnanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & slianl(len), scvanl(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2), + & smcanl(len,lsoil), stcanl(len,lsoil), + & tsfan0(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! logical gaus @@ -3792,36 +3788,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 == 1) then + irtalb=iret + if(iret.eq.1) then write(6,*) 'albedo analysis read error' call abort - elseif(iret == -1) then - if (me == 0) then + elseif(iret.eq.-1) then + if (me .eq. 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 == 0 .and. kk == 4) + if (me .eq. 0 .and. kk .eq. 4) & print *,'albedo analysis provided.' endif enddo else - if (me == 0) then + if (me .eq. 0) then ! print *,'************************************************' print *,'no albedo analysis available. climatology used' endif @@ -3829,30 +3825,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 == 1) then + irtalf=iret + if(iret.eq.1) then write(6,*) 'albedo analysis read error' call abort - elseif(iret == -1) then - if (me == 0) then + elseif(iret.eq.-1) then + if (me .eq. 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 == 0 .and. kk == 4) + if (me .eq. 0 .and. kk .eq. 4) & print *,'albedo analysis provided.' endif enddo else - if (me == 0) then + if (me .eq. 0) then ! print *,'************************************************' print *,'no vegfalbedo analysis available. climatology used' endif @@ -4340,45 +4336,53 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! return end - subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & - & tg3fcs,cvfcs ,cvbfcs,cvtfcs, & - & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, & - & vegfcs, vetfcs, sotfcs, alffcs, & - & sihfcs,sicfcs, & !cwu [+1l] add ()fcs for sih, sic - & vmnfcs,vmxfcs,slpfcs,absfcs, & !clu [+1l] add ()fcs for vmn, vmx, slp, abs - & tsfanl,wetanl,snoanl,zoranl,albanl, & - & tg3anl,cvanl ,cvbanl,cvtanl, & - & cnpanl,smcanl,stcanl,slianl,aisanl, & - & veganl, vetanl, sotanl, alfanl, & - & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic - & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs + subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, + & tg3fcs,cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, + & vegfcs, vetfcs, sotfcs, alffcs, +!cwu [+1l] add ()fcs for sih, sic + & sihfcs,sicfcs, +!clu [+1l] add ()fcs for vmn, vmx, slp, abs + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsfanl,wetanl,snoanl,zoranl,albanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,aisanl, + & veganl, vetanl, sotanl, alfanl, +!cwu [+1l] add ()anl for sih, sic + & sihanl,sicanl, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, & len,lsoil) ! use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil - real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), & - & zorfcs(len),albfcs(len,4),aisfcs(len), & - & tg3fcs(len), & - & cvfcs (len),cvbfcs(len),cvtfcs(len), & - & cnpfcs(len), & - & smcfcs(len,lsoil),stcfcs(len,lsoil), & - & slifcs(len),vegfcs(len), & - & vetfcs(len),sotfcs(len),alffcs(len,2) & - &, sihfcs(len),sicfcs(len) & - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), & - & zoranl(len),albanl(len,4),aisanl(len), & - & tg3anl(len), & - & cvanl (len),cvbanl(len),cvtanl(len), & - & cnpanl(len), & - & smcanl(len,lsoil),stcanl(len,lsoil), & - & slianl(len),veganl(len), & - & vetanl(len),sotanl(len),alfanl(len,2) & - &, sihanl(len),sicanl(len) & + real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), + & zorfcs(len),albfcs(len,4),aisfcs(len), + & tg3fcs(len), + & cvfcs (len),cvbfcs(len),cvtfcs(len), + & cnpfcs(len), + & smcfcs(len,lsoil),stcfcs(len,lsoil), + & slifcs(len),vegfcs(len), + & vetfcs(len),sotfcs(len),alffcs(len,2) +!cwu [+1l] add ()fcs for sih, sic + &, sihfcs(len),sicfcs(len) +!clu [+1l] add ()fcs for vmn, vmx, slp, abs + &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) + real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), + & zoranl(len),albanl(len,4),aisanl(len), + & tg3anl(len), + & cvanl (len),cvbanl(len),cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len),veganl(len), + & vetanl(len),sotanl(len),alfanl(len,2) +!cwu [+1l] add ()anl for sih, sic + &, sihanl(len),sicanl(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! - write(6,*) ' this is a dead start run, tsfc over land is', & + write(6,*) ' this is a dead start run, tsfc over land is', & ' set as lowest sigma level temperture if given.' write(6,*) ' if not, set to climatological tsf over land is used' ! @@ -4429,7 +4433,7 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil,k - real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), & + real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), & slianl(len) ! ! note that smfcs comes in with the original unit (cm?) (not grib file) @@ -4452,97 +4456,43 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) ! return end - subroutine rof01(aisfld, len, op, crit) + subroutine rof01(aisfld,len,op,crit) use machine , only : kind_io8,kind_io4 implicit none integer i,len real (kind=kind_io8) aisfld(len),crit character*2 op ! - if(op == 'ge') then + if(op.eq.'ge') then do i=1,len - if(aisfld(i) >= crit) then - aisfld(i) = 1. + if(aisfld(i).ge.crit) then + aisfld(i)=1. else - aisfld(i) = 0. + aisfld(i)=0. endif enddo - elseif(op == 'gt') then + elseif(op.eq.'gt') then do i=1,len - if(aisfld(i) > crit) then - aisfld(i) = 1. + if(aisfld(i).gt.crit) then + aisfld(i)=1. else - aisfld(i) = 0. + aisfld(i)=0. endif enddo - elseif(op == 'le') then + elseif(op.eq.'le') then do i=1,len - if(aisfld(i) <= crit) then - aisfld(i) = 1. + if(aisfld(i).le.crit) then + aisfld(i)=1. else - aisfld(i) = 0. + aisfld(i)=0. endif enddo - elseif(op == 'lt') then + elseif(op.eq.'lt') then do i=1,len - if(aisfld(i) < crit) then - aisfld(i) = 1. + if(aisfld(i).lt.crit) then + aisfld(i)=1. else - aisfld(i) = 0. - endif - enddo - else - write(6,*) ' illegal operator in rof01. op=',op - call abort - endif -! - return - end - subroutine rof01_len(aisfld, len, op, lake, critl, crits) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - logical :: lake(len) - real (kind=kind_io8) aisfld(len), critl, crits, crit(len) - character*2 op -! - do i=1,len - if (lake(i)) then - crit(i) = critl - else - crit(i) = crits - endif - enddo - if(op == 'ge') then - do i=1,len - if(aisfld(i) >= 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. + aisfld(i)=0. endif enddo else @@ -4567,7 +4517,7 @@ subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) enddo return end - subroutine snodpth(scvanl,slianl,tsfanl,snoclm, & + subroutine snodpth(scvanl,slianl,tsfanl,snoclm, & glacir,snwmax,snwmin,landice,len,snoanl, me) use machine , only : kind_io8,kind_io4 implicit none @@ -4575,7 +4525,7 @@ subroutine snodpth(scvanl,slianl,tsfanl,snoclm, & logical, intent(in) :: landice real (kind=kind_io8) sno,snwmax,snwmin ! - real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), & + real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), & snoclm(len), snoanl(len), glacir(len) ! if (me .eq. 0) write(6,*) 'snodpth' @@ -4621,80 +4571,80 @@ subroutine snodpth(scvanl,slianl,tsfanl,snoclm, & enddo return end subroutine snodpth - subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & - & sihfcs,sicfcs, & - & vmnfcs,vmxfcs,slpfcs,absfcs, & - & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & - & cvfcs ,cvbfcs,cvtfcs, & - & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, & - & vetfcs,sotfcs,alffcs, & - & sihanl,sicanl, & - & vmnanl,vmxanl,slpanl,absanl, & - & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl,& - & cvanl ,cvbanl,cvtanl, & - & cnpanl,smcanl,stcanl,slianl,veganl, & - & vetanl,sotanl,alfanl, & - & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, & - & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, & - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, & - & calfl,calfs, & - & csihl,csihs,csicl,csics, & - & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & - & irtvmn,irtvmx,irtslp,irtabs, & + subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, + & sihfcs,sicfcs, + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, + & cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, + & vetfcs,sotfcs,alffcs, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, + & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, + & cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,veganl, + & vetanl,sotanl,alfanl, + & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, + & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, + & calfl,calfs, + & csihl,csihs,csicl,csics, + & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvmn,irtvmx,irtslp,irtabs, & irtvet,irtsot,irtalf, landice, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : veg_type_landice, soil_type_landice implicit none - integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & - & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & - & irtalb,irtsno,irttsf,irtwet,j & + integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, + & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, + & irtalb,irtsno,irttsf,irtwet,j &, irtvmn,irtvmx,irtslp,irtabs logical, intent(in) :: landice - real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, & - & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, & - & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, & - & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, & - & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, & - & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, & - & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, & - & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, & - & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, & - & cvets,calfs,deltsfc, & - & csihl,csihs,csicl,csics, & - & rsihl,rsihs,rsicl,rsics, & - & qsihl,qsihs,qsicl,qsics & - &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps & - &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs & - &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns & + real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, + & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, + & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, + & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, + & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, + & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, + & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, + & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, + & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, + & cvets,calfs,deltsfc, + & csihl,csihs,csicl,csics, + & rsihl,rsihs,rsicl,rsics, + & qsihl,qsihs,qsicl,qsics + &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps + &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs + &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss ! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & - & zorfcs(len), albfcs(len,4), aisfcs(len), & - & cvfcs (len), cvbfcs(len), cvtfcs(len), & - & cnpfcs(len), & - & smcfcs(len,lsoil),stcfcs(len,lsoil), & - & slifcs(len), vegfcs(len), & - & vetfcs(len), sotfcs(len), alffcs(len,2) & - &, sihfcs(len), sicfcs(len) & + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), + & zorfcs(len), albfcs(len,4), aisfcs(len), + & cvfcs (len), cvbfcs(len), cvtfcs(len), + & cnpfcs(len), + & smcfcs(len,lsoil),stcfcs(len,lsoil), + & slifcs(len), vegfcs(len), + & vetfcs(len), sotfcs(len), alffcs(len,2) + &, sihfcs(len), sicfcs(len) &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),tsfan2(len), & - & wetanl(len),snoanl(len), & - & zoranl(len), albanl(len,4), aisanl(len), & - & cvanl (len), cvbanl(len), cvtanl(len), & - & cnpanl(len), & - & smcanl(len,lsoil),stcanl(len,lsoil), & - & slianl(len), veganl(len), & - & vetanl(len), sotanl(len), alfanl(len,2) & - &, sihanl(len),sicanl(len) & + real (kind=kind_io8) tsfanl(len),tsfan2(len), + & wetanl(len),snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2) + &, sihanl(len),sicanl(len) &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! - real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), & + real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), & cstcl(lsoil), cstcs(lsoil) - real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), & + real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), & rstcl(lsoil), rstcs(lsoil) - real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), & + real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), & qstcl(lsoil), qstcs(lsoil) logical first integer num_threads @@ -5072,17 +5022,18 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & !$omp end parallel do return end subroutine merge - subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & - & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl - & albanl,snoanl,zoranl,smcanl,stcanl, & - & albsea,snosea,zorsea,smcsea,smcice, & - & tsfmin,tsfice,albice,zorice,tgice, & + subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, +!cwu [+1l] add sihnew,sicnew,sihanl,sicanl + & sihnew,sicnew,sihanl,sicanl, + & albanl,snoanl,zoranl,smcanl,stcanl, + & albsea,snosea,zorsea,smcsea,smcice, + & tsfmin,tsfice,albice,zorice,tgice, & rla,rlo,me) ! use machine , only : kind_io8,kind_io4 implicit none real (kind=kind_io8), parameter :: one=1.0 - real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, & + real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, & smcice,tsfmin,zorsea,smcsea !cwu [+1l] add sicnew,sihnew &, sicnew,sihnew @@ -5167,7 +5118,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & ! return end - subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, & + subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, & landice,me) use machine , only : kind_io8,kind_io4 implicit none @@ -5213,20 +5164,20 @@ subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, & endif return end subroutine qcsnow - subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, & + subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, & rla,rlo,len,me) use machine , only : kind_io8,kind_io4 implicit none integer kount1,kount,i,me,len real (kind=kind_io8) per,aicsea,aicice,sllnd ! - real (kind=kind_io8) ais(len), glacir(len), & + real (kind=kind_io8) ais(len), glacir(len), & amxice(len), slmask(len) real (kind=kind_io8) rla(len), rlo(len) ! ! check sea-ice cover mask against land-sea mask ! - if (me == 0) write(6,*) 'qc of sea ice' + if (me .eq. 0) write(6,*) 'qc of sea ice' kount = 0 kount1 = 0 do i=1,len @@ -5324,8 +5275,9 @@ subroutine setlsi(slmask,aisfld,len,aicice,slifld) ! do i=1,len slifld(i) = slmask(i) - if(aisfld(i) == aicice .and. slmask(i) == 0.0) & - & slifld(i) = 2.0 +! if(aisfld(i).eq.aicice) slifld(i) = 2.0 + if(aisfld(i).eq.aicice .and. slmask(i) .eq. 0.0) + & slifld(i) = 2.0 enddo return end @@ -5340,63 +5292,66 @@ subroutine scale(fld,len,scl) enddo return end - subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & - & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, & - & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, & + subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, + & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, + & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, & rla,rlo,len,mode,percrit,lgchek,me) ! use machine , only : kind_io8,kind_io4 implicit none - 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 + 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) ! character*8 ttl logical iceflg(len) - real (kind=kind_io8), dimension(len) :: fld, slimsk, sno, rla, rlo + real (kind=kind_io8) fld(len),slimsk(len),sno(len), + & rla(len), rlo(len) + integer iwk(len) 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, num_parthds, & - & kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,kminj, & - & ij,nprt,kmaxs,kmins,i - integer :: islimsk(len), iwk(len) + integer len_thread_m, i1_t, i2_t, it + integer num_parthds ! 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 == 0) then - print *,'performing qc of ',ttl,' mode=',mode, - & '(0=count only, 1=replace)' + if(me .eq. 0) then +! print *,' ' + 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,islimsk,sno,rla,rlo) +!$omp+shared(fld,slimsk,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) @@ -5405,24 +5360,24 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over bare land ! - if (fldlmn /= 999.0) then + if (fldlmn .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) <= 0.0 & - & .and. fld(i) < fldlmn-epsfld) then - kminl = kminl + 1 + if(slimsk(i).eq.1..and.sno(i).le.0..and. + & fld(i).lt.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 == 1) then + if (mode .eq. 1) then do i=1,kminl fld(iwk(i)) = fldlmn enddo @@ -5431,11 +5386,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over bare land ! - if (fldlmx /= 999.0) then + if (fldlmx .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) <= 0.0 & - & .and. fld(i) > fldlmx+epsfld) then - kmaxl = kmaxl + 1 + if(slimsk(i).eq.1..and.sno(i).le.0..and. + & fld(i).gt.fldlmx+epsfld) then + kmaxl=kmaxl+1 iwk(kmaxl) = i endif enddo @@ -5444,11 +5399,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 == 1) then + if (mode .eq. 1) then do i=1,kmaxl fld(iwk(i)) = fldlmx enddo @@ -5457,11 +5412,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over snow covered land ! - if (fldsmn /= 999.0) then + if (fldsmn .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) > 0.0 & - & .and. fld(i) < fldsmn-epsfld) then - kmins = kmins + 1 + if(slimsk(i).eq.1..and.sno(i).gt.0..and. + & fld(i).lt.fldsmn-epsfld) then + kmins=kmins+1 iwk(kmins) = i endif enddo @@ -5470,11 +5425,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 == 1) then + if (mode .eq. 1) then do i=1,kmins fld(iwk(i)) = fldsmn enddo @@ -5483,11 +5438,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over snow covered land ! - if (fldsmx /= 999.0) then + if (fldsmx .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) > 0.0 & - & .and. fld(i) > fldsmx+epsfld) then - kmaxs = kmaxs + 1 + if(slimsk(i).eq.1..and.sno(i).gt.0..and. + & fld(i).gt.fldsmx+epsfld) then + kmaxs=kmaxs+1 iwk(kmaxs) = i endif enddo @@ -5496,11 +5451,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,i & + 8004 format(' snow land max. check. lat=',f5.1, & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode == 1) then + if (mode .eq. 1) then do i=1,kmaxs fld(iwk(i)) = fldsmx enddo @@ -5509,10 +5464,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over open ocean ! - if (fldomn /= 999.0) then + if (fldomn .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 0.0 .and. fld(i) < fldomn-epsfld) then - kmino = kmino + 1 + if(slimsk(i).eq.0..and. + & fld(i).lt.fldomn-epsfld) then + kmino=kmino+1 iwk(kmino) = i endif enddo @@ -5521,11 +5477,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 == 1) then + if (mode .eq. 1) then do i=1,kmino fld(iwk(i)) = fldomn enddo @@ -5534,23 +5490,24 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over open ocean ! - if (fldomx /= 999.0) then + if (fldomx .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) ==.0 .and. fld(i) > fldomx+epsfld) then - kmaxo = kmaxo+1 + if(fldomx.ne.999..and.slimsk(i).eq.0..and. + & fld(i).gt.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 == 1) then + if (mode .eq. 1) then do i=1,kmaxo fld(iwk(i)) = fldomx enddo @@ -5559,11 +5516,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over sea ice without snow ! - if (fldimn /= 999.0) then + if (fldimn .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) <= 0.0 & - & .and. fld(i) < fldimn-epsfld) then - kmini = kmini + 1 + if(slimsk(i).eq.2..and.sno(i).le.0..and. + & fld(i).lt.fldimn-epsfld) then + kmini=kmini+1 iwk(kmini) = i endif enddo @@ -5572,11 +5529,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 == 1) then + if (mode .eq. 1) then do i=1,kmini fld(iwk(i)) = fldimn enddo @@ -5585,12 +5542,12 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over sea ice without snow ! - if (fldimx /= 999.0) then + if (fldimx .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) <= 0.0 .and. & - & fld(i) > fldimx+epsfld .and. iceflg(i)) then + if(slimsk(i).eq.2..and.sno(i).le.0..and. + & fld(i).gt.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 +5556,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 == 1) then + if (mode .eq. 1) then do i=1,kmaxi fld(iwk(i)) = fldimx enddo @@ -5612,11 +5569,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over sea ice with snow ! - if (fldjmn /= 999.0) then + if (fldjmn .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) > 0.0 .and. & - & fld(i) < fldjmn-epsfld) then - kminj = kminj + 1 + if(slimsk(i).eq.2..and.sno(i).gt.0..and. + & fld(i).lt.fldjmn-epsfld) then + kminj=kminj+1 iwk(kminj) = i endif enddo @@ -5625,11 +5582,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 == 1) then + if (mode .eq. 1) then do i=1,kminj fld(iwk(i)) = fldjmn enddo @@ -5638,12 +5595,12 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over sea ice with snow ! - if (fldjmx /= 999.0) then + if (fldjmx .ne. 999.0) then do i=i1_t,i2_t - if(islimsk(i) == 2 .and.sno(i) > 0.0 .and. & - & fld(i)> fldjmx+epsfld .and. iceflg(i)) then + if(slimsk(i).eq.2..and.sno(i).gt.0..and. + & fld(i).gt.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 +5609,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 == 1) then + if (mode .eq. 1) then do i=1,kmaxj fld(iwk(i)) = fldjmx enddo @@ -5667,77 +5624,78 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! print results ! - if(me == 0) then - permax = 0.0 - if(kminl > 0) then - per = float(kminl)/float(len)*100. + if(me .eq. 0) then +! write(6,*) 'summary of qc' + permax=0. + if(kminl.gt.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 > permax) permax = per + if(per.gt.permax) permax=per endif - if(kmaxl > 0) then - per = float(kmaxl)/float(len)*100. + if(kmaxl.gt.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 > 0) then - per = float(kmino)/float(len)*100. + if(kmino.gt.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 > 0) then - per = float(kmaxo)/float(len)*100. + if(kmaxo.gt.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 >.0) then - per = float(kmins)/float(len)*100. + if(kmins.gt.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 > 0) then - per = float(kmaxs)/float(len)*100. + if(kmaxs.gt.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 > 0) then - per = float(kmini)/float(len)*100. + if(kmini.gt.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 > 0) then - per = float(kmaxi)/float(len)*100. + if(kmaxi.gt.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 > permax) permax=per + if(per.gt.permax) permax=per endif - if(kminj > 0) then - per = float(kminj)/float(len)*100. + if(kminj.gt.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 > 0) then - per = float(kmaxj)/float(len)*100. + if(kmaxj.gt.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 > permax) permax=per + if(per.gt.permax) permax=per endif ! commented on 06/30/99 -- moorthi ! if(lgchek) then @@ -5826,7 +5784,7 @@ subroutine getsmc(wetfld,len,lsoil,smcfld,me) enddo return end - subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, & + subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, & tsfimx) ! use machine , only : kind_io8,kind_io4 @@ -5972,21 +5930,23 @@ subroutine qcsli(slianl,slifcs,len,me) !1111 format(80i1) ! return ! end - subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, & - & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, & - & zoranl,smcanl,smcclm,tsfsmx,albomx,zoromx, me) + subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, + & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, + & zoranl,smcanl, + & smcclm,tsfsmx,albomx,zoromx, me) ! use machine , only : kind_io8,kind_io4 implicit none integer kount,me,k,i,lsoil,len real (kind=kind_io8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx real (kind=kind_io8) tsffcs(len), snofcs(len) - real (kind=kind_io8) snoanl(len), aisanl(len), & - & slianl(len), zoranl(len), & - & tsfanl(len), albanl(len,4), & - & smcanl(len,lsoil), smcclm(len,lsoil) + 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) ! - if (me == 0) write(6,*) 'qc of snow and sea-ice analysis' + if (me .eq. 0) write(6,*) 'qc of snow and sea-ice analysis' ! ! qc of snow analysis ! @@ -5994,7 +5954,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. @@ -6066,8 +6026,8 @@ subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, & ! return end - subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & - & data,imax,jmax,rlnout,rltout,lmask,rslmsk & + subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, + & data,imax,jmax,rlnout,rltout,lmask,rslmsk &, gaus,blno, blto, kgds1, kpds4, lbms) use machine , only : kind_io8,kind_io4 use sfccyc_module @@ -6547,25 +6507,25 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & ! return end - subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, & + subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, & wlon,rnlat,rlnout,rltout,gaus,blno, blto) use machine , only : kind_io8,kind_io4 implicit none - integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, & + integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, & j,iret - real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, & - & rnlat,dxout,dphi,dlat,facns,tem,blno, & + real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, + & rnlat,dxout,dphi,dlat,facns,tem,blno, & blto ! ! interpolation from lat/lon grid to other lat/lon grid ! - real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) & + real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) &, rlnout(imxout), rltout(jmxout) logical gaus ! real, allocatable :: gaul(:) real (kind=kind_io8) ddx(imxout),ddy(jmxout) - integer iindx1(imxout), iindx2(imxout), & + integer iindx1(imxout), iindx2(imxout), & jindx1(jmxout), jindx2(jmxout) integer jmxsav,n,kspla data jmxsav/0/ @@ -6797,8 +6757,8 @@ subroutine landtyp(vegtype,soiltype,slptype,slmask,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) & - &, slptype(len) + real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) + +, slptype(len) ! ! make sure that the soil type and veg type are non-zero over land ! @@ -6810,7 +6770,6 @@ subroutine landtyp(vegtype,soiltype,slptype,slmask,len) endif enddo return - end subroutine landtyp subroutine gaulat(gaul,k) ! @@ -6841,7 +6800,7 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) tsfanl(len), tsfan0(len), & + real (kind=kind_io8) tsfanl(len), tsfan0(len), & tsfclm(len), tsfcl0(len) ! ! time interpolation of anomalies @@ -6853,53 +6812,53 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) enddo return end - subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & - & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,& - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & - & fnvetc,fnsotc, & - & fnvmnc,fnvmxc,fnslpc,fnabsc, & - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm,& - & tg3clm,cvclm ,cvbclm,cvtclm, & - & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm,& - & vetclm,sotclm,alfclm, & - & vmnclm,vmxclm,slpclm,absclm, & - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, & - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & - & kpdvet,kpdsot,kpdalf,tsfcl0, & - & kpdvmn,kpdvmx,kpdslp,kpdabs, & - & deltsfc, lanom & - &, imsk, jmsk, slmskh, outlat, outlon & - &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb & + subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, + & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fnvetc,fnsotc, + & fnvmnc,fnvmxc,fnslpc,fnabsc, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, + & vetclm,sotclm,alfclm, + & vmnclm,vmxclm,slpclm,absclm, + & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kpdvet,kpdsot,kpdalf,tsfcl0, + & kpdvmn,kpdvmx,kpdslp,kpdabs, + & deltsfc, lanom + &, imsk, jmsk, slmskh, outlat, outlon + &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb &, tile_num_ch, i_index, j_index) ! use machine , only : kind_io8,kind_io4 implicit none character(len=*), intent(in) :: tile_num_ch integer, intent(in) :: i_index(len), j_index(len) - real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, & + real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2 real (kind=kind_io8) wei1y,wei2y - integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, & - & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, & - & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, & - & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, & - & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb & + integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, + & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, + & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, + & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, + & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat integer kpdalb(4), kpdalf(2) ! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & - & fnvetc,fnsotc,fnalbc2 & + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fnvetc,fnsotc,fnalbc2 &, fnvmnc,fnvmxc,fnslpc,fnabsc - real (kind=kind_io8) tsfclm(len),tsfcl2(len), & - & wetclm(len),snoclm(len), & - & zorclm(len),albclm(len,4),aisclm(len), & - & tg3clm(len),acnclm(len), & - & cvclm (len),cvbclm(len),cvtclm(len), & - & cnpclm(len), & - & smcclm(len,lsoil),stcclm(len,lsoil), & - & sliclm(len),scvclm(len),vegclm(len), & - & vetclm(len),sotclm(len),alfclm(len,2) & + real (kind=kind_io8) tsfclm(len),tsfcl2(len), + & wetclm(len),snoclm(len), + & zorclm(len),albclm(len,4),aisclm(len), + & tg3clm(len),acnclm(len), + & cvclm (len),cvbclm(len),cvtclm(len), + & cnpclm(len), + & smcclm(len,lsoil),stcclm(len,lsoil), + & sliclm(len),scvclm(len),vegclm(len), + & vetclm(len),sotclm(len),alfclm(len,2) &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) @@ -8023,8 +7982,8 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! return end subroutine clima - subroutine fixrdc_tile(filename_raw, tile_num_ch, & - & i_index, j_index, kpds, & + subroutine fixrdc_tile(filename_raw, tile_num_ch, + & i_index, j_index, kpds, & var, mon, npts, me) use netcdf use machine , only : kind_io8 @@ -8173,15 +8132,15 @@ subroutine netcdf_err(error) call abort end subroutine netcdf_err - subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, & - & gdata,len,iret & - &, imsk, jmsk, slmskh, gaus,blno, blto & + subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, + & gdata,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata implicit none - integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, & - & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami & + integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, + & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami &, jj,w3kindreal,w3kindint real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto ! @@ -8349,18 +8308,18 @@ subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, & deallocate(lbms) return end subroutine fixrdc - subroutine fixrda(lugb,fngrib,kpds5,slmask, & - & iy,im,id,ih,fh,gdata,len,iret & - &, imsk, jmsk, slmskh, gaus,blno, blto & + subroutine fixrda(lugb,fngrib,kpds5,slmask, + & iy,im,id,ih,fh,gdata,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata implicit none - integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, & - & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, & - & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, & - & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint - real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, & + integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, + & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, + & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, + & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint + real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, & rjday,blto ! ! read in grib climatology/analysis files and interpolate to the input