module sfccyc_module
implicit none
SAVE
!
! GRIB code for each parameter - Used in subroutines SFCCYCLE and SETRMSK.
!
INTEGER kpdtsf,kpdwet,kpdsno,kpdzor,kpdais,kpdtg3,kpdplr,kpdgla,
& kpdmxi,kpdscv,kpdsmc,kpdoro,kpdmsk,kpdstc,kpdacn,kpdveg,
& kpdvet,kpdsot
!Clu [+1L] add kpd() for vmn, vmx, slp, abs
&, kpdvmn,kpdvmx,kpdslp,kpdabs
!cggg snow mods start add snow depth
&, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4)
!cggg snow mods end
PARAMETER(KPDTSF=11, KPDWET=86, KPDSNO=65, KPDZOR=83,
! 1 KPDALB=84, KPDAIS=91, KPDTG3=11, KPDPLR=224,
1 KPDAIS=91, KPDTG3=11, KPDPLR=224,
2 KPDGLA=238, KPDMXI=91, KPDSCV=238, KPDSMC=144,
3 KPDORO=8, KPDMSK=81, KPDSTC=11, KPDACN=91, KPDVEG=87,
!Clu [+1L] add kpd() for vmn, vmx, slp, abs
!cbosu max snow albedo uses a grib id number of 159, not 255.
& kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255,
& kpdvet=225, kpdsot=230,kpdabs_1=159,
!cggg snow mods start
& kpdsnd=66 )
!cggg snow mods end
!
integer, parameter :: kpdalb_0(4)=(/212,215,213,216/)
integer, parameter :: kpdalb_1(4)=(/189,190,191,192/)
integer, parameter :: kpdalf(2)=(/214,217/)
!
integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata
!
end module sfccyc_module
SUBROUTINE SFCCYCLE(LUGB,LEN,LSOIL,SIG1T,DELTSFC
&, IY,IM,ID,IH,FH
&, RLA, RLO, SLMASK,OROG,orog_uf,use_ufo
!Cwu [+1L] add SIHFCS and SICFCS
&, SIHFCS,SICFCS,SITFCS
!Clu [+2L] add SWD, SLC, VMN, VMX, SLP, ABS
&, SWDFCS,SLCFCS
&, VMNFCS,VMXFCS,SLPFCS,ABSFCS
&, TSFFCS,SNOFCS,ZORFCS,ALBFCS,TG3FCS
&, CNPFCS,SMCFCS,STCFCS,SLIFCS,AISFCS,F10M
&, VEGFCS,VETFCS,SOTFCS,ALFFCS
&, CVFCS,CVBFCS,CVTFCS,me,NLUNIT,IALB)
!
USE MACHINE , ONLY : kind_io8,kind_io4
USE sfccyc_module
implicit none
logical use_ufo
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
!Cwu [+2L] add f()l,f()s,c()l,c()s,eps() for sih, sic
&, fsihl,fsihs,fsicl,fsics,
& csihl,csihs,csicl,csics,epssih,epssic
!Clu [+4L] add f()l,f()s,c()l,c()s,eps() for vmn, vmx, slp, abs
&, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps,
& fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs,
& cslpl,cslps,cabsl,cabss,epsvmn,epsvmx,
& epsslp,epsabs
!Cwu [+4L] add min/max for sih and sic
&, sihlmx,sihlmn,sihomx,sihomn,sihsmx,
& sihsmn,sihimx,sihimn,sihjmx,sihjmn,
& siclmx,siclmn,sicomx,sicomn,sicsmx,
& sicsmn,sicimx,sicimn,sicjmx,sicjmn
&, glacir_hice
!Clu [+8L] add min/max for vmn, vmx, slp, abs
&, 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
!Cwu [+1L] add sihnew
&, 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,IALB
!Clu [+1L] add irt() for vmn, vmx, slp, abs
&, irtvmn, irtvmx, irtslp, irtabs
LOGICAL GAUSM, DEADS, QCMSK, ZNLST, MONCLM, MONANL,
!cggg landice mods start.
! & MONFCS, MONMER, MONDIF
& MONFCS, MONMER, MONDIF, LANDICE
!cggg landice mods end
integer NUM_PARTHDS
!
! THIS IS A limited point VERSION of SURFACE PROGRAM.
!
! This program runs in two different modes:
!
! 1. Analysis mode (FH=0.)
!
! This program merges climatology, analysis and forecast guess to create
! new surface fields. If analysis file is given, the program
! uses it if date of the analysis matches with IY,IM,ID,IH (see Note
! below).
!
! 2. Forecast mode (FH.GT.0.)
!
! This program interpolates climatology to the date corresponding to the
! forecast hour. If surface analysis file is given, for the corresponding
! dates, the program will use it.
!
! NOTE:
!
! If the date of the analysis does not match given IY,IM,ID,IH, (and FH),
! the program searches an old analysis by going back 6 hours, then 12 hours,
! then one day upto NREPMX days (parameter statement in the SUBROTINE FIXRD.
! Now defined as 8). This allows the user to provide non-daily analysis to
! be used. If matching field is not found, the forecast guess will be used.
!
! Use of a combined earlier surface analyses and current analysis is
! NOT allowed (as was done in the old version for snow analysis in which
! old snow analysis is used in combination with initial guess), except
! for sea surface temperature. For sst anolmaly interpolation, you need to
! set LANOM=.TRUE. and must provide sst analysis at initial time.
!
! If you want to do complex merging of past and present surface field analysis,
! YOU NEED TO CREATE a separate file that contains DAILY SURFACE FIELD.
!
! For a dead start, do not supply FNBGSI or set FNBGSI=' '
!
! LUGB is the unit number used in this subprogram
! LEN ... Number of points on which sfccyc operates
! LSOIL .. Number of soil layers (2 as of April, 1994)
! IY,IM,ID,IH .. Year, month, day, and hour of initial state.
! FH .. Forecast hour
! RLA, RLO -- Latitude and longitudes of the LEN points
! SIG1T .. Sigma level 1 temperature for dead start. Should be on Gaussian
! grid. If not dead start, no need for dimension but set to zero
! as in the example below.
!
! Variable naming conventions:
!
! ORO .. Orography
! ALB .. Albedo
! WET .. Soil wetness as defined for bucket model
! SNO .. Snow DEPTH
! ZOR .. Surface roughness length
! VET .. Vegetation type
! PLR .. Plant evaporation resistance
! TSF .. Surface skin temperature. Sea surface temp. over ocean.
! TG3 .. Deep soil temperature (at 500cm)
! STC .. Soil temperature (LSOIL layrs)
! SMC .. Soil moisture (LSOIL layrs)
! SCV .. Snow cover (not snow depth)
! AIS .. Sea ice mask (0 or 1)
! ACN .. Sea ice concentration (fraction)
! GLA .. Glacier (permanent snow) mask (0 or 1)
! MXI .. Maximum sea ice extent (0 or 1)
! MSK .. Land ocean mask (0=ocean 1=land)
! CNP .. Canopy water content
! CV .. Convective cloud cover
! CVB .. Convective cloud base
! CVT .. Convective cloud top
! SLI .. LAND/SEA/SEA-ICE mask. (1/0/2 respectively)
! VEG .. Vegetation cover
! SOT .. Soil type
!Cwu [+2L] add SIH & SIC
! SIH .. Sea ice thickness
! SIC .. Sea ice concentration
!Clu [+6L] add SWD,SLC,VMN,VMX,SLP,ABS
! SWD .. Actual snow depth
! SLC .. Liquid soil moisture (LSOIL layers)
! VMN .. Vegetation cover minimum
! VMX .. Vegetation cover maximum
! SLP .. Slope type
! ABS .. Maximum snow albedo
!
! Definition of Land/Sea mask. SLLND for land and SLSEA for sea.
! Definition of Sea/ice mask. AICICE for ice, AICSEA for sea.
! TGICE=max ice temperature
! RLAPSE=lapse rate for sst correction due to surface angulation
!
PARAMETER(SLLND =1.0,SLSEA =0.0)
PARAMETER(AICICE=1.0,AICSEA=0.0)
PARAMETER(TGICE=271.2)
PARAMETER(RLAPSE=0.65E-2)
!
! Max/Min of fields for check and replace.
!
! ???LMX .. Max over bare land
! ???LMN .. Min over bare land
! ???OMX .. Max over open ocean
! ???OMN .. Min over open ocean
! ???SMX .. Max over snow surface (land and sea-ice)
! ???SMN .. Min over snow surface (land and sea-ice)
! ???IMX .. Max over bare sea ice
! ???IMN .. Min over bare sea ice
! ???JMX .. Max over snow covered sea ice
! ???JMN .. Min over snow covered sea ice
!
PARAMETER(OROLMX=8000.,OROLMN=-1000.,OROOMX=3000.,OROOMN=-1000.,
& OROSMX=8000.,OROSMN=-1000.,OROIMX=3000.,OROIMN=-1000.,
& OROJMX=3000.,OROJMN=-1000.)
! PARAMETER(ALBLMX=0.80,ALBLMN=0.06,ALBOMX=0.06,ALBOMN=0.06,
! & ALBSMX=0.80,ALBSMN=0.06,ALBIMX=0.80,ALBIMN=0.80,
! & ALBJMX=0.80,ALBJMN=0.80)
!Cwu [-3L/+9L] change min/max for ALB; add min/max for SIH & SIC
! PARAMETER(ALBLMX=0.80,ALBLMN=0.01,ALBOMX=0.01,ALBOMN=0.01,
! & ALBSMX=0.80,ALBSMN=0.01,ALBIMX=0.01,ALBIMN=0.01,
! & ALBJMX=0.01,ALBJMN=0.01)
! note: the range values for bare land and snow covered land
! (ALBLMX, ALBLMN, ALBSMX, ALBSMN) are set below
! based on whether the old or new radiation is selected
PARAMETER(ALBOMX=0.06,ALBOMN=0.06,
& ALBIMX=0.80,ALBIMN=0.06,
& ALBJMX=0.80,ALBJMN=0.06)
PARAMETER(SIHLMX=0.0,SIHLMN=0.0,SIHOMX=5.0,SIHOMN=0.0,
& SIHSMX=5.0,SIHSMN=0.0,SIHIMX=5.0,SIHIMN=0.10,
& SIHJMX=5.0,SIHJMN=0.10,glacir_hice=3.0)
PARAMETER(SICLMX=0.0,SICLMN=0.0,SICOMX=1.0,SICOMN=0.0,
& SICSMX=1.0,SICSMN=0.0,SICIMX=1.0,SICIMN=0.50,
& SICJMX=1.0,SICJMN=0.50)
!
! PARAMETER(SIHLMX=0.0,SIHLMN=0.0,SIHOMX=8.0,SIHOMN=0.0,
! & SIHSMX=8.0,SIHSMN=0.0,SIHIMX=8.0,SIHIMN=0.10,
! & SIHJMX=8.0,SIHJMN=0.10,glacir_hice=3.0)
! PARAMETER(SICLMX=0.0,SICLMN=0.0,SICOMX=1.0,SICOMN=0.0,
! & SICSMX=1.0,SICSMN=0.0,SICIMX=1.0,SICIMN=0.15,
! & SICJMX=1.0,SICJMN=0.15)
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,
& WETJMX=0.15,WETJMN=0.15)
!Clu [-1L/+1L] revise SNOSMN (for Noah LSM)
PARAMETER(SNOLMX=0.0,SNOLMN=0.0,SNOOMX=0.0,SNOOMN=0.0,
!* & SNOSMX=55000.,SNOSMN=0.01,SNOIMX=0.,SNOIMN=0.0,
!cggg landice mods start, should SNOSMN be set to .001 as in noah
!cggg & SNOSMX=55000.,SNOSMN=0.0001,SNOIMX=0.,SNOIMN=0.0,
& SNOSMX=55000.,SNOSMN=0.001,SNOIMX=0.,SNOIMN=0.0,
!cggg landice mods end
& SNOJMX=10000.,SNOJMN=0.01)
PARAMETER(ZORLMX=300.,ZORLMN=2.,ZOROMX=1.0,ZOROMN=1.E-05,
& ZORSMX=300.,ZORSMN=2.,ZORIMX=1.0,ZORIMN=1.0,
& ZORJMX=1.0,ZORJMN=1.0)
PARAMETER(PLRLMX=1000.,PLRLMN=0.0,PLROMX=1000.0,PLROMN=0.0,
& PLRSMX=1000.,PLRSMN=0.0,PLRIMX=1000.,PLRIMN=0.0,
& PLRJMX=1000.,PLRJMN=0.0)
!Clu [-1L/+1L] relax TSFSMX (for Noah LSM)
PARAMETER(TSFLMX=353.,TSFLMN=173.0,TSFOMX=313.0,TSFOMN=271.2,
& TSFSMX=305.0,TSFSMN=173.0,TSFIMX=271.2,TSFIMN=173.0,
& TSFJMX=273.16,TSFJMN=173.0)
! PARAMETER(TSFLMX=353.,TSFLMN=173.0,TSFOMX=313.0,TSFOMN=271.21,
!* & TSFSMX=273.16,TSFSMN=173.0,TSFIMX=271.21,TSFIMN=173.0,
! & TSFSMX=305.0,TSFSMN=173.0,TSFIMX=271.21,TSFIMN=173.0,
PARAMETER(TG3LMX=310.,TG3LMN=200.0,TG3OMX=310.0,TG3OMN=200.0,
& TG3SMX=310.,TG3SMN=200.0,TG3IMX=310.0,TG3IMN=200.0,
& TG3JMX=310.,TG3JMN=200.0)
PARAMETER(STCLMX=353.,STCLMN=173.0,STCOMX=313.0,STCOMN=200.0,
& STCSMX=310.,STCSMN=200.0,STCIMX=310.0,STCIMN=200.0,
& STCJMX=310.,STCJMN=200.0)
!cggg landice mods start. force a flag value of soil moisture of 1.0
! at non-land points
! PARAMETER(SMCLMX=0.55,SMCLMN=0.0,SMCOMX=0.55,SMCOMN=0.0,
! & SMCSMX=0.55,SMCSMN=0.0,SMCIMX=0.55,SMCIMN=0.0,
! & SMCJMX=0.55,SMCJMN=0.0)
PARAMETER(SMCLMX=0.55,SMCLMN=0.0,SMCOMX=1.0,SMCOMN=1.0,
& SMCSMX=0.55,SMCSMN=0.0,SMCIMX=1.0,SMCIMN=1.0,
& SMCJMX=1.0,SMCJMN=1.0)
!cggg landice mods end.
PARAMETER(SCVLMX=0.0,SCVLMN=0.0,SCVOMX=0.0,SCVOMN=0.0,
& SCVSMX=1.0,SCVSMN=1.0,SCVIMX=0.0,SCVIMN=0.0,
& SCVJMX=1.0,SCVJMN=1.0)
PARAMETER(VEGLMX=1.0,VEGLMN=0.0,VEGOMX=0.0,VEGOMN=0.0,
& VEGSMX=1.0,VEGSMN=0.0,VEGIMX=0.0,VEGIMN=0.0,
& VEGJMX=0.0,VEGJMN=0.0)
!Clu [+12L] set min/max for VMN, VMX, SLP, ABS
PARAMETER(VMNLMX=1.0,VMNLMN=0.0,VMNOMX=0.0,VMNOMN=0.0,
& VMNSMX=1.0,VMNSMN=0.0,VMNIMX=0.0,VMNIMN=0.0,
& VMNJMX=0.0,VMNJMN=0.0)
PARAMETER(VMXLMX=1.0,VMXLMN=0.0,VMXOMX=0.0,VMXOMN=0.0,
& VMXSMX=1.0,VMXSMN=0.0,VMXIMX=0.0,VMXIMN=0.0,
& VMXJMX=0.0,VMXJMN=0.0)
PARAMETER(SLPLMX=9.0,SLPLMN=1.0,SLPOMX=0.0,SLPOMN=0.0,
!cggg landice mods start
!cggg & SLPSMX=9.0,SLPSMN=1.0,SLPIMX=9.0,SLPIMN=9.0,
!cggg & SLPJMX=9.0,SLPJMN=9.0)
& SLPSMX=9.0,SLPSMN=1.0,SLPIMX=0.,SLPIMN=0.,
& SLPJMX=0.,SLPJMN=0.)
!cggg landice mods end
! note: the range values for bare land and snow covered land
! (ALBLMX, ALBLMN, ALBSMX, ALBSMN) are set below
! based on whether the old or new radiation is selected
PARAMETER(ABSOMX=0.0,ABSOMN=0.0,
& ABSIMX=0.0,ABSIMN=0.0,
& ABSJMX=0.0,ABSJMN=0.0)
! vegetation type
PARAMETER(VETLMX=13.,VETLMN=1.0,VETOMX=0.0,VETOMN=0.0,
!cggg landice mods start
!cggg & VETSMX=13.,VETSMN=1.0,VETIMX=13.,VETIMN=13.0,
!cggg & VETJMX=13.,VETJMN=13.0)
& VETSMX=13.,VETSMN=1.0,VETIMX=0.,VETIMN=0.,
& VETJMX=0.,VETJMN=0.)
!cggg landice mods end
! soil type
PARAMETER(SOTLMX=9.,SOTLMN=1.0,SOTOMX=0.0,SOTOMN=0.0,
!cggg landice mods start
!cggg & SOTSMX=9.,SOTSMN=1.0,SOTIMX=9.,SOTIMN=9.0,
!cggg & SOTJMX=9.,SOTJMN=0.0)
& SOTSMX=9.,SOTSMN=1.0,SOTIMX=0.,SOTIMN=0.,
& SOTJMX=0.,SOTJMN=0.)
!cggg landice mods end
! fraction of vegetation for strongly and weakly zeneith angle dependent
! albedo
PARAMETER(ALSLMX=1.0,ALSLMN=0.0,ALSOMX=0.0,ALSOMN=0.0,
& ALSSMX=1.0,ALSSMN=0.0,ALSIMX=0.0,ALSIMN=0.0,
& ALSJMX=0.0,ALSJMN=0.0)
!
! Criteria used for monitoring
!
PARAMETER(EPSTSF=0.01,EPSALB=0.001,EPSSNO=0.01,
& EPSWET=0.01,EPSZOR=0.0000001,EPSPLR=1.,EPSORO=0.,
& EPSSMC=0.0001,EPSSCV=0.,EPTSFC=0.01,EPSTG3=0.01,
& EPSAIS=0.,EPSACN=0.01,EPSVEG=0.01,
!Cwu [+1L] add eps() for sih, sic
& EPSSIH=0.001,EPSSIC=0.001,
!Clu [+1L] add eps() for vmn, vmx, abs, slp
& EPSVMN=0.01,EPSVMX=0.01,EPSABS=0.001,EPSSLP=0.01,
& epsvet=.01,epssot=.01,epsalf=.001)
!
! Quality control of analysis snow and sea ice
!
! QCTSFS .. Surface temperature above which no snow allowed
! QCSNOS .. Snow depth above which snow must exist
! QCTSFI .. SST above which sea-ice is not allowed
!
!Clu relax QCTSFS (for Noah LSM)
!* PARAMETER(QCTSFS=283.16,QCSNOS=100.,QCTSFI=280.16)
!* PARAMETER(QCTSFS=288.16,QCSNOS=100.,QCTSFI=280.16)
PARAMETER(QCTSFS=293.16,QCSNOS=100.,QCTSFI=280.16)
!
!Cwu [-2L]
!* Ice concentration for ice limit (55 percent)
!
!* PARAMETER(AISLIM=0.55)
!
! Parameters to obtain snow depth from snow cover and temperature
!
! PARAMETER(SNWMIN=25.,SNWMAX=100.)
PARAMETER(SNWMIN=5.0,SNWMAX=100.)
real (kind=kind_io8), parameter :: ten=10.0, one=1.0
!
! COEEFICIENTS OF BLENDING FORECAST AND INTERPOLATED CLIM
! (OR ANALYZED) FIELDS OVER SEA OR LAND(L) (NOT FOR CLOUDS)
! 1.0 = USE OF FORECAST
! 0.0 = REPLACE WITH INTERPOLATED ANALYSIS
!
! These values are set for analysis mode.
!
! Variables Land Sea
! ---------------------------------------------------------
! Surface temperature Forecast Analysis
!Cwu [+1L]
! Surface temperature Forecast Forecast (over sea ice)
! Albedo Analysis Analysis
! Sea-ice Analysis Analysis
! Snow Analysis Forecast (over sea ice)
! Roughness Analysis Forecast
! Plant resistance Analysis Analysis
! Soil wetness (layer) Weighted average Analysis
! Soil temperature Forecast Analysis
! Canopy waver content Forecast Forecast
! Convective cloud cover Forecast Forecast
! Convective cloud bottm Forecast Forecast
! Convective cloud top Forecast Forecast
! Vegetation cover Analysis Analysis
! vegetation type Analysis Analysis
! soil type Analysis Analysis
!Cwu [+2L]
! Sea-ice thickness Forecast Forecast
! Sea-ice concentration Analysis Analysis
!Clu [+6L]
! Vegetation cover min Analysis Analysis
! Vegetation cover max Analysis Analysis
! Max snow albedo Analysis Analysis
! Slope type Analysis Analysis
! Liquid Soil wetness Analysis-weighted Analysis
! Actual snow depth Analysis-weighted Analysis
!
! Note: If analysis file is not given, then time interpolated climatology
! is used. If analyiss file is given, it will be used as far as the
! date and time matches. If they do not match, it uses forecast.
!
! Critical percentage value for aborting bad points when LGCHEK=.TRUE.
!
LOGICAL LGCHEK
DATA LGCHEK/.TRUE./
DATA CRITP1,CRITP2,CRITP3/80.,80.,25./
!
! integer kpdalb(4), kpdalf(2)
! data kpdalb/212,215,213,216/, kpdalf/214,217/
! save kpdalb, kpdalf
!
! MASK OROGRAPHY AND VARIANCE ON GAUSSIAN GRID
!
REAL (KIND=KIND_IO8) SLMASK(LEN),OROG(LEN), orog_uf(len)
&, orogd(len)
REAL (KIND=KIND_IO8) RLA(LEN), RLO(LEN)
!
! Permanent/extremes
!
CHARACTER*500 FNGLAC,FNMXIC
real (kind=kind_io8), allocatable :: GLACIR(:),AMXICE(:),TSFCL0(:)
!
! TSFCL0 is the climatological TSF at FH=0
!
! 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
!Clu [+1L] add FN()C for vmn, vmx, slp, abs
&, 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)
!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)
!
! 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
!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), 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)
!Cwu [+1L] add SIHANL & SICANL
&, 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) 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)
!Cwu [+1L] add SIHFCS & SICFCS
&, SIHFCS(LEN), SICFCS(LEN), SITFCS(LEN)
!Clu [+2L] add ()FCS for VMN, VMX, SLP, ABS, SWD, SLC
&, 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
! in this program).
!
REAL (KIND=KIND_IO8) F10M (LEN)
REAL (KIND=KIND_IO8) FSMCL(25),FSMCS(25),FSTCL(25),FSTCS(25)
REAL (KIND=KIND_IO8) FCSMCL(25),FCSMCS(25),FCSTCL(25),FCSTCS(25)
!Clu [+1L] add SWRATIO (soil moisture liquid-to-total ratio)
REAL (KIND=KIND_IO8) SWRATIO(LEN,LSOIL)
!Clu [+1L] add FIXRATIO (option to adjust slc from smc)
LOGICAL FIXRATIO(LSOIL)
!
INTEGER ICSMCL(25), ICSMCS(25), ICSTCL(25), ICSTCS(25)
!
REAL (KIND=KIND_IO8) CSMCL(25), CSMCS(25)
REAL (KIND=KIND_IO8) CSTCL(25), CSTCS(25)
!
REAL (KIND=KIND_IO8) SLMSKH(mdata)
CHARACTER*500 FNMSKH
Integer kpd9
!
logical icefl1(len), icefl2(len)
!
! Input and output SURFACE FIELDS (BGES) file names
!
!
! Sigma level 1 temperature for dead start
!
REAL (KIND=KIND_IO8) SIG1T(LEN), WRK(LEN)
!
CHARACTER*32 LABEL
!
! = 1 ==> FORECAST IS USED
! = 0 ==> ANALYSIS (OR CLIMATOLOGY) IS USED
!
! OUTPUT FILE ... PRIMARY SURFACE FILE FOR RADIATION AND FORECAST
!
! REC. 1 LABEL
! REC. 2 DATE RECORD
! REC. 3 TSF
! REC. 4 SOILM(TWO LAYERS) ----> 4 layers
! REC. 5 SNOW
! REC. 6 SOILT(TWO LAYERS) ----> 4 layers
! REC. 7 TG3
! REC. 8 ZOR
! REC. 9 CV
! REC. 10 CVB
! REC. 11 CVT
! REC. 12 ALBEDO (four types)
! REC. 13 SLIMSK
! REC. 14 vegetation cover
! REC. 14 PLANTR -----> skip this record
! REC. 15 F10M -----> CANOPY
! REC. 16 CANOPY WATER CONTENT (CNPANL) -----> F10M
! REC. 17 vegetation type
! REC. 18 soil type
! REC. 19 zeneith angle dependent vegetation fraction (two types)
! REC. 20 UUSTAR
! REC. 21 FFMM
! REC. 22 FFHH
!Cwu add SIH & SIC
! REC. 23 SIH(one category only)
! REC. 24 SIC
!Clu [+8L] add PRCP, FLAG, SWD, SLC, VMN, VMX, SLP, ABS
! REC. 25 TPRCP
! REC. 26 SRFLAG
! REC. 27 SWD
! REC. 28 SLC (4 LAYERS)
! REC. 29 VMN
! REC. 30 VMX
! REC. 31 SLP
! REC. 32 ABS
!
! Debug only
! LDEBUG=.TRUE. creates BGES files for climatology and analysis
! LQCBGS=.TRUE. Quality controls input BGES file before merging (should have been
! QCed in the forecast program)
!
LOGICAL LDEBUG,LQCBGS
logical lprnt
!
! Debug only
!
CHARACTER*500 FNDCLM,FNDANL
!
LOGICAL LANOM
!
NAMELIST/NAMSFC/FNGLAC,FNMXIC,
& FNTSFC,FNWETC,FNSNOC,FNZORC,FNALBC,FNAISC,
& FNPLRC,FNTG3C,FNSCVC,FNSMCC,FNSTCC,FNACNC,
& FNVEGC,fnvetc,fnsotc,FNALBC2,
!Clu [+1L] add fn()c for vmn, vmx, slp, abs
& FNVMNC,FNVMXC,FNSLPC,FNABSC,
& FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
& FNPLRA,FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,
& FNVEGA,fnveta,fnsota,
!Clu [+1L] add fn()a for vmn, vmx, slp, abs
& FNVMNA,FNVMXA,FNSLPA,FNABSA,
& FNMSKH,
& LDEBUG,LGCHEK,LQCBGS,CRITP1,CRITP2,CRITP3,
& FNDCLM,FNDANL,
& LANOM,
& FTSFL,FTSFS,FALBL,FALBS,FAISL,FAISS,FSNOL,FSNOS,
& FZORL,FZORS,FPLRL,FPLRS,FSMCL,FSMCS,
& FSTCL,FSTCS,fvegl,fvegs,fvetl,fvets,fsotl,fsots,
& FCTSFL,FCTSFS,FCALBL,FCALBS,FCSNOL,FCSNOS,
& FCZORL,FCZORS,FCPLRL,FCPLRS,FCSMCL,FCSMCS,
& FCSTCL,FCSTCS,fsalfl,fsalfs,fcalfl,flalfs,
!Cwu [+1L] add f()l and f()s for sih, sic and aislim, sihnew
& FSIHL,FSICL,FSIHS,FSICS,AISLIM,SIHNEW,
!Clu [+2L] add f()l and f()s for vmn, vmx, slp, abs
& FVMNL,FVMNS,FVMXL,FVMXS,FSLPL,FSLPS,
& FABSL,FABSS,
& ICTSFL,ICTSFS,ICALBL,ICALBS,ICSNOL,ICSNOS,
& ICZORL,ICZORS,ICPLRL,ICPLRS,ICSMCL,ICSMCS,
& ICSTCL,ICSTCS,icalfl,icalfs,
!
& GAUSM, DEADS, QCMSK, ZNLST,
& MONCLM, MONANL, MONFCS, MONMER, MONDIF, IGRDBG,
!cggg landice mods start
! & BLNMSK, BLTMSK
& BLNMSK, BLTMSK, LANDICE
!cggg landice mods end
!
DATA GAUSM/.TRUE./, DEADS/.FALSE./, BLNMSK/0.0/, BLTMSK/90.0/
&, QCMSK/.FALSE./, ZNLST/.FALSE./, IGRDBG/-1/
&, MONCLM/.FALSE./, MONANL/.FALSE./, MONFCS/.FALSE./
!cggg landice mods start
! &, MONMER/.FALSE./, MONDIF/.FALSE./
&, MONMER/.FALSE./, MONDIF/.FALSE./, LANDICE/.TRUE./
!cggg landice mods end
!
! Defaults file names
!
DATA FNMSKH/'global_slmask.t126.grb'/
DATA FNALBC/'global_albedo4.1x1.grb'/
DATA FNALBC2/'/nwprod/fix/global_albedo4.1x1.grb'/
DATA FNTSFC/'global_sstclim.2x2.grb'/
DATA FNSOTC/'global_soiltype.1x1.grb'/
DATA FNVEGC/'global_vegfrac.1x1.grb'/
DATA FNVETC/'global_vegtype.1x1.grb'/
DATA FNGLAC/'global_glacier.2x2.grb'/
DATA FNMXIC/'global_maxice.2x2.grb'/
DATA FNSNOC/'global_snoclim.1.875.grb'/
DATA FNZORC/'global_zorclim.1x1.grb'/
DATA FNAISC/'global_iceclim.2x2.grb'/
DATA FNTG3C/'global_tg3clim.2.6x1.5.grb'/
DATA FNSMCC/'global_soilmcpc.1x1.grb'/
!Clu [+4L] add fn()c for vmn, vmx, abs, slp
DATA FNVMNC/'global_shdmin.0.144x0.144.grb'/
DATA FNVMXC/'global_shdmax.0.144x0.144.grb'/
DATA FNSLPC/'global_slope.1x1.grb'/
DATA FNABSC/'global_snoalb.1x1.grb'/
!
DATA FNWETC/' '/
DATA FNPLRC/' '/
DATA FNSTCC/' '/
DATA FNSCVC/' '/
DATA FNACNC/' '/
!
DATA FNTSFA/' '/
DATA FNWETA/' '/
DATA FNSNOA/' '/
DATA FNZORA/' '/
DATA FNALBA/' '/
DATA FNAISA/' '/
DATA FNPLRA/' '/
DATA FNTG3A/' '/
DATA FNSMCA/' '/
DATA FNSTCA/' '/
DATA FNSCVA/' '/
DATA FNACNA/' '/
DATA FNVEGA/' '/
DATA FNVETA/' '/
DATA FNSOTA/' '/
!Clu [+4L] add fn()a for vmn, vmx, abs, slp
DATA FNVMNA/' '/
DATA FNVMXA/' '/
DATA FNSLPA/' '/
DATA FNABSA/' '/
!
DATA LDEBUG/.FALSE./, LQCBGS/.TRUE./
DATA FNDCLM/' '/
DATA FNDANL/' '/
DATA LANOM/.FALSE./
!
! DEFAULT RELAXATION TIME IN HOURS TO ANALYSIS OR CLIMATOLOGY
DATA FTSFL/99999.0/, FTSFS/0.0/
DATA FALBL/0.0/, FALBS/0.0/
DATA FALFL/0.0/, FALFS/0.0/
DATA FAISL/0.0/, FAISS/0.0/
DATA FSNOL/0.0/, FSNOS/99999.0/
DATA FZORL/0.0/, FZORS/99999.0/
DATA FPLRL/0.0/, FPLRS/0.0/
DATA FvetL/0.0/, FvetS/99999.0/
DATA FsotL/0.0/, FsotS/99999.0/
DATA FVegL/0.0/, FvegS/99999.0/
!Cwu [+4L] add f()l and f()s for sih, sic and aislim, sihlim
DATA FsihL/99999.0/, FsihS/99999.0/
! DATA FsicL/99999.0/, FsicS/99999.0/
DATA FsicL/0.0/, FsicS/0.0/
! DEFAULT ice concentration limit (50%), new ice thickness (20cm)
DATA AISLIM/0.50/, SIHNEW/0.2/
!Clu [+4L] add f()l and f()s for vmn, vmx, abs, slp
DATA FvmnL/0.0/, FvmnS/99999.0/
DATA FvmxL/0.0/, FvmxS/99999.0/
DATA FslpL/0.0/, FslpS/99999.0/
DATA FabsL/0.0/, FabsS/99999.0/
! DEFAULT RELAXATION TIME IN HOURS TO CLIMATOLOGY IF ANALYSIS MISSING
DATA FCTSFL/99999.0/, FCTSFS/99999.0/
DATA FCALBL/99999.0/, FCALBS/99999.0/
DATA FCSNOL/99999.0/, FCSNOS/99999.0/
DATA FCZORL/99999.0/, FCZORS/99999.0/
DATA FCPLRL/99999.0/, FCPLRS/99999.0/
! DEFAULT FLAG TO APPLY CLIMATOLOGICAL ANNUAL CYCLE
DATA ICTSFL/0/, ICTSFS/1/
DATA ICALBL/1/, ICALBS/1/
DATA ICALFL/1/, ICALFS/1/
DATA ICSNOL/0/, ICSNOS/0/
DATA ICZORL/1/, ICZORS/0/
DATA ICPLRL/1/, ICPLRS/0/
!
DATA CCNP/1.0/
DATA CCV/1.0/, CCVB/1.0/, CCVT/1.0/
!
DATA IFP/0/
!
SAVE IFP,FNGLAC,FNMXIC,
& FNTSFC,FNWETC,FNSNOC,FNZORC,FNALBC,FNAISC,
& FNPLRC,FNTG3C,FNSCVC,FNSMCC,FNSTCC,FNACNC,FNVEGC,
& FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
& FNPLRA,FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,FNVEGA,
& fnvetc,fnveta,
& fnsotc,fnsota,
!Clu [+2L] add fn()c and fn()a for vmn, vmx, slp, abs
& FNVMNC,FNVMXC,FNABSC,FNSLPC,
& FNVMNA,FNVMXA,FNABSA,FNSLPA,
& LDEBUG,LGCHEK,LQCBGS,CRITP1,CRITP2,CRITP3,
& FNDCLM,FNDANL,
& LANOM,
& FTSFL,FTSFS,FALBL,FALBS,FAISL,FAISS,FSNOL,FSNOS,
& FZORL,FZORS,FPLRL,FPLRS,FSMCL,FSMCS,falfl,falfs,
& FSTCL,FSTCS,fvegl,fvegs,fvetl,fvets,fsotl,fsots,
& FCTSFL,FCTSFS,FCALBL,FCALBS,FCSNOL,FCSNOS,
& FCZORL,FCZORS,FCPLRL,FCPLRS,FCSMCL,FCSMCS,
& FCSTCL,FCSTCS,fcalfl,fcalfs,
!Cwu [+1L] add f()l and f()s for sih, sic and aislim, sihnew
& FSIHL,FSIHS,FSICL,FSICS,AISLIM,SIHNEW,
!Clu [+2L] add f()l and f()s for vmn, vmx, slp, abs
& FVMNL,FVMNS,FVMXL,FVMXS,FSLPL,FSLPS,
& FABSL,FABSS,
& ICTSFL,ICTSFS,ICALBL,ICALBS,ICSNOL,ICSNOS,
& ICZORL,ICZORS,ICPLRL,ICPLRS,ICSMCL,ICSMCS,
& ICSTCL,ICSTCS,icalfl,icalfs,
& GAUSM, DEADS, QCMSK,
& MONCLM, MONANL, MONFCS, MONMER, MONDIF, IGRDBG,
& GRBORO, GRBMSK,
!
& CTSFL, CTSFS, CALBL, CALFL, CALBS, CALFS, CSMCS,
& CSNOL, CSNOS, CZORL, CZORS, CPLRL, CPLRS, CSTCL,
& CSTCS, CvegL, CvwgS, CvetL, CvetS, CsotL, CsotS,
& CSMCL
!Cwu [+1L] add c()l and c()s for sih, sic
&, CSIHL, CSIHS, CSICL, CSICS
!Clu [+2L] add c()l and c()s for vmn, vmx, slp, abs
&, CVMNL, CVMNS, CVMXL, CVMXS, CSLPL, CSLPS,
& CABSL, CABSS
&, IMSK, JMSK, SLMSKH, BLNMSK, BLTMSK
&, GLACIR, AMXICE, TSFCL0
&, caisl, caiss, cvegs
!
lprnt = .false.
iprnt = 1
! do i=1,len
! 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))
! if(tem1 .lt. 0.25 .and. tem2 .lt. 0.50) then
! lprnt = .true.
! iprnt = i
! print *,' lprnt=',lprnt,' iprnt=',iprnt
! print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i)
! endif
! enddo
if (ialb == 1) then
kpdabs = kpdabs_1
kpdalb = kpdalb_1
alblmx = .99
albsmx = .99
alblmn = .01
albsmn = .01
abslmx = 1.0
abssmx = 1.0
abssmn = .01
abslmn = .01
else
kpdabs = kpdabs_0
kpdalb = kpdalb_0
alblmx = .80
albsmx = .80
alblmn = .06
albsmn = .06
abslmx = .80
abssmx = .80
abslmn = .01
abssmn = .01
endif
IF(IFP.EQ.0) THEN
IFP = 1
DO K=1,LSOIL
FSMCL(K) = 99999.
FSMCS(K) = 0.
FSTCL(K) = 99999.
FSTCS(K) = 0.
ENDDO
! print *,' IN SFCSUB NLUNIT=',NLUNIT,' me=',me,' ialb=',ialb
rewind(NLUNIT)
READ (NLUNIT,NAMSFC)
! WRITE(6,NAMSFC)
!
if (me .eq. 0) then
print *,'FTSFL,FALBL,FAISL,FSNOL,FSMCL,FZORL,FSTCL=',
& FTSFL,FALBL,FAISL,FSNOL,FSMCL,FZORL,FSTCL
print *,'FTSFS,FALBS,FAISS,FSNOS,FSMCS,FZORS,FSTCS=',
& FTSFS,FALBS,FAISS,FSNOS,FSMCS,FZORS,FSTCS
print *,' AISLIM=',aislim,' SIHNEW=',SIHNEW
endif
!
DELTF = DELTSFC / 24.0
!
CTSFL=0. !... tsfc over land
IF(FTSFL.GE.99999.) CTSFL=1.
IF((FTSFL.GT.0.).AND.(FTSFL.LT.99999)) CTSFL=EXP(-DELTF/FTSFL)
!
CTSFS=0. !... tsfc over sea
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).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).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.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.GE.99999.) CALFL=1.
IF((FALFL.GT.0.).AND.(FALFL.LT.99999)) CALFL=EXP(-DELTF/FALFL)
!
CALBS=0. !... albedo over sea
IF(FALBS.GE.99999.) CALBS=1.
IF((FALBS.GT.0.).AND.(FALBS.LT.99999)) CALBS=EXP(-DELTF/FALBS)
!
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.GE.99999.) CAISL=1.
IF((FAISL.GT.0.).AND.(FAISL.LT.99999)) CAISL=1.
!
CAISS=0. !... sea ice over sea
IF(FAISS.GE.99999.) CAISS=1.
IF((FAISS.GT.0.).AND.(FAISS.LT.99999)) CAISS=1.
!
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.LT.0.)CSNOL=FSNOL
!
CSNOS=0. !... snow over sea
IF(FSNOS.GE.99999.) CSNOS=1.
IF((FSNOS.GT.0.).AND.(FSNOS.LT.99999)) CSNOS=EXP(-DELTF/FSNOS)
!
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.GE.99999.) CZORS=1.
IF((FZORS.GT.0.).AND.(FZORS.LT.99999)) CZORS=EXP(-DELTF/FZORS)
!
! CPLRL=0. !... plant resistance over land
! IF(FPLRL.GE.99999.) CPLRL=1.
! IF((FPLRL.GT.0.).AND.(FPLRL.LT.99999)) CPLRL=EXP(-DELTF/FPLRL)
!
! 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).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.GE.99999.) CvegL=1.
IF((FvegL.GT.0.).AND.(FvegL.LT.99999)) CvegL=EXP(-DELTF/FvegL)
!
CvegS=0. !... Vegetation fraction over sea
IF(FvegS.GE.99999.) CvegS=1.
IF((FvegS.GT.0.).AND.(FvegS.LT.99999)) CvegS=EXP(-DELTF/FvegS)
!
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.GE.99999.) CvetS=1.
IF((FvetS.GT.0.).AND.(FvetS.LT.99999)) CvetS=EXP(-DELTF/FvetS)
!
CsotL=0. !... Soil type over land
IF(FsotL.GE.99999.) CsotL=1.
IF((FsotL.GT.0.).AND.(FsotL.LT.99999)) CsotL=EXP(-DELTF/FsotL)
!
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.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.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.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.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.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.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.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.GE.99999.) CvmxS=1.
IF((FvmxS.GT.0.).AND.(FvmxS.LT.99999)) CvmxS=EXP(-DELTF/FvmxS)
!
CslpL=0. !... Slope type over land
IF(FslpL.GE.99999.) CslpL=1.
IF((FslpL.GT.0.).AND.(FslpL.LT.99999)) CslpL=EXP(-DELTF/FslpL)
!
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.GE.99999.) CabsL=1.
IF((FabsL.GT.0.).AND.(FabsL.LT.99999)) CabsL=EXP(-DELTF/FabsL)
!
CabsS=0. !... Snow albedo over sea
IF(FabsS.GE.99999.) CabsS=1.
IF((FabsS.GT.0.).AND.(FabsS.LT.99999)) CabsS=EXP(-DELTF/FabsS)
!Clu ----------------------------------------------------------------------
!
! Read a high resolution MASK field for use in grib interpolation
!
CALL HMSKRD(LUGB,IMSK,JMSK,FNMSKH,
& KPDMSK,SLMSKH,GAUSM,BLNMSK,BLTMSK,me)
! IF (QCMSK) CALL QCMASK(SLMSKH,SLLND,SLSEA,IMSK,JMSK,RLA,RLO)
!
if (me .eq. 0) then
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)
&, ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk
WRITE(6,*) ' '
endif
!
! Reading Permanent/extreme features (glacier points and maximum ice extent)
!
allocate (TSFCL0(LEN))
allocate (GLACIR(LEN))
allocate (AMXICE(LEN))
!
! Read Glacier
!
kpd9 = -1
CALL FIXRDC(LUGB,FNGLAC,KPDGLA,kpd9,SLMASK,
& GLACIR,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUSM, BLNMSK, BLTMSK
&, RLA, RLO, me)
! ZNNT=1.
! CALL NNTPRT(GLACIR,LEN,ZNNT)
!
! Read Maximum ice extent
!
CALL FIXRDC(LUGB,FNMXIC,KPDMXI,kpd9,SLMASK,
& AMXICE,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUSM, BLNMSK, BLTMSK
&, RLA, RLO, me)
! ZNNT=1.
! CALL NNTPRT(AMXICE,LEN,ZNNT)
!
CRIT=0.5
CALL ROF01(GLACIR,LEN,'GE',CRIT)
CALL ROF01(AMXICE,LEN,'GE',CRIT)
!
! Quality control max ice limit based on glacier points
!
CALL QCMXICE(GLACIR,AMXICE,LEN,me)
!
ENDIF ! First time loop finished
!
DO I=1,LEN
SLICLM(I) = 1.
SNOCLM(I) = 0.
icefl1(i) = .true.
ENDDO
! if(lprnt) print *,' tsffcsIN=',tsffcs(iprnt)
!
! Read climatology fields
!
if (me .eq. 0) then
WRITE(6,*) '=============='
WRITE(6,*) 'CLIMATOLOGY'
WRITE(6,*) '=============='
endif
!
PERCRIT=CRITP1
!
CALL CLIMA(LUGB,IY,IM,ID,IH,FH,LEN,LSOIL,SLMASK,
& FNTSFC,FNWETC,FNSNOC,FNZORC,FNALBC,FNAISC,
& FNTG3C,FNSCVC,FNSMCC,FNSTCC,FNACNC,FNVEGC,
& fnvetc,fnsotc,
!Clu [+1L] add fn()c for vmn, vmx, slp, abs
& 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,
!Clu [+1L] add ()clm for vmn, vmx, slp, abs
& VMNCLM,VMXCLM,SLPCLM,ABSCLM,
& KPDTSF,KPDWET,KPDSNO,KPDZOR,KPDALB,KPDAIS,
& KPDTG3,KPDSCV,KPDACN,KPDSMC,KPDSTC,KPDVEG,
& kpdvet,kpdsot,kpdalf,TSFCL0,
!Clu [+1L] add kpd() for vmn, vmx, slp, abs
& KPDVMN,KPDVMX,KPDSLP,KPDABS,
& DELTSFC, LANOM
&, IMSK, JMSK, SLMSKH, RLA, RLO, GAUSM, BLNMSK, BLTMSK,me
&, lprnt, iprnt, FNALBC2, IALB)
! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt)
!
! Scale surface roughness and albedo to model required units
!
ZSCA=100.
CALL SCALE(ZORCLM,LEN,ZSCA)
ZSCA=0.01
CALL SCALE(ALBCLM,LEN,ZSCA)
CALL SCALE(ALBCLM(1,2),LEN,ZSCA)
CALL SCALE(ALBCLM(1,3),LEN,ZSCA)
CALL SCALE(ALBCLM(1,4),LEN,ZSCA)
CALL SCALE(ALFCLM,LEN,ZSCA)
CALL SCALE(ALFCLM(1,2),LEN,ZSCA)
!Clu [+4L] scale vmn, vmx, abs from percent to fraction
ZSCA=0.01
CALL SCALE(VMNCLM,LEN,ZSCA)
CALL SCALE(VMXCLM,LEN,ZSCA)
CALL SCALE(ABSCLM,LEN,ZSCA)
!
! Set albedo over ocean to ALBOMX
!
CALL ALBOCN(ALBCLM,SLMASK,ALBOMX,LEN)
!
! make sure vegetation type and soil type are non zero over land
!
!Clu [-1L/+1L]: add slpclm
!Clu call landtyp(vetclm,sotclm,slmask,LEN)
call landtyp(vetclm,sotclm,slpclm,slmask,LEN)
!
!Cwu [-1L/+1L]
!* Ice concentration or ice mask (only ice mask used in the model now)
! Ice concentration and ice mask (both are used in the model now)
!
IF(FNAISC(1:8).NE.' ') THEN
!Cwu [+5L/-1L] Update SIHCLM, SICCLM
DO I=1,LEN
SIHCLM(I) = 3.0*AISCLM(I)
SICCLM(I) = AISCLM(I)
IF(SLMASK(I).EQ.0..AND.GLACIR(I).EQ.1..AND.
& SICCLM(I).NE.1.) THEN
SICCLM(I) = SICIMX
SIHFCS(I) = glacir_hice
ENDIF
ENDDO
CRIT=AISLIM
!* CRIT=0.5
CALL ROF01(AISCLM,LEN,'GE',CRIT)
ELSEIF(FNACNC(1:8).NE.' ') THEN
!Cwu [+4L] Update SIHCLM, SICCLM
DO I=1,LEN
SIHCLM(I) = 3.0*ACNCLM(I)
SICCLM(I) = ACNCLM(I)
IF(SLMASK(I).EQ.0..AND.GLACIR(I).EQ.1..AND.
& SICCLM(I).NE.1.) THEN
SICCLM(I) = SICIMX
SIHFCS(I) = glacir_hice
ENDIF
ENDDO
CALL ROF01(ACNCLM,LEN,'GE',AISLIM)
DO I=1,LEN
AISCLM(I) = ACNCLM(I)
ENDDO
ENDIF
!
! Quality control of sea ice mask
!
CALL QCSICE(AISCLM,GLACIR,AMXICE,AICICE,AICSEA,SLLND,SLMASK,
& RLA,RLO,LEN,me)
!
! 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)
!
! WRITE(6,*) 'SLICLM'
! ZNNT=1.
! CALL NNTPRT(SLICLM,LEN,ZNNT)
!
! Quality control of snow
!
!cggg landice mods start
! CALL QCSNOW(SNOCLM,SLMASK,AISCLM,GLACIR,LEN,SNOSMX,me)
CALL QCSNOW(SNOCLM,SLMASK,AISCLM,GLACIR,LEN,SNOSMX,LANDICE,me)
!cggg landice mods end
!
CALL SETZRO(SNOCLM,EPSSNO,LEN)
!
! Snow cover handling (We assume climatological snow depth is available)
! Quality control of snow depth (Note that Snow should be corrected first
! because it influences TSF
!
KQCM=1
CALL QCMXMN('Snow ',SNOCLM,SLICLM,SNOCLM,icefl1,
& SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
& SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! WRITE(6,*) 'SNOCLM'
! ZNNT=1.
! CALL NNTPRT(SNOCLM,LEN,ZNNT)
!
! Get snow cover from snow depth array
!
IF(FNSCVC(1:8).EQ.' ') THEN
CALL GETSCV(SNOCLM,SCVCLM,LEN)
ENDIF
!
! Set TSFC over snow to TSFSMX if greater
!
CALL SNOSFC(SNOCLM,TSFCLM,TSFSMX,LEN,me)
! CALL SNOSFC(SNOCLM,TSFCL2,TSFSMX,LEN)
!
! Quality control
!
do i=1,len
icefl2(i) = sicclm(i) .gt. 0.99999
enddo
KQCM=1
CALL QCMXMN('TSFc ',TSFCLM,SLICLM,SNOCLM,icefl2,
& TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
& TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('TSf2 ',TSFCL2,SLICLM,SNOCLM,icefl2,
& TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
& TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
do kk = 1, 4
CALL QCMXMN('ALBc ',ALBCLM(1,kk),SLICLM,SNOCLM,icefl1,
& ALBLMX,ALBLMN,ALBOMX,ALBOMN,ALBIMX,ALBIMN,
& ALBJMX,ALBJMN,ALBSMX,ALBSMN,EPSALB,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
enddo
IF(FNWETC(1:8).NE.' ') THEN
CALL QCMXMN('WETc ',WETCLM,SLICLM,SNOCLM,icefl1,
& WETLMX,WETLMN,WETOMX,WETOMN,WETIMX,WETIMN,
& WETJMX,WETJMN,WETSMX,WETSMN,EPSWET,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
CALL QCMXMN('ZORc ',ZORCLM,SLICLM,SNOCLM,icefl1,
& ZORLMX,ZORLMN,ZOROMX,ZOROMN,ZORIMX,ZORIMN,
& ZORJMX,ZORJMN,ZORSMX,ZORSMN,EPSZOR,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! IF(FNPLRC(1:8).NE.' ') THEN
! CALL QCMXMN('PLNTc ',PLRCLM,SLICLM,SNOCLM,icefl1,
! & PLRLMX,PLRLMN,PLROMX,PLROMN,PLRIMX,PLRIMN,
! & PLRJMX,PLRJMN,PLRSMX,PLRSMN,EPSPLR,
! & RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! ENDIF
CALL QCMXMN('TG3c ',TG3CLM,SLICLM,SNOCLM,icefl1,
& TG3LMX,TG3LMN,TG3OMX,TG3OMN,TG3IMX,TG3IMN,
& TG3JMX,TG3JMN,TG3SMX,TG3SMN,EPSTG3,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!
! Get soil temp and moisture (after all the QCs are completed)
!
IF(FNSMCC(1:8).EQ.' ') THEN
CALL GETSMC(WETCLM,LEN,LSOIL,SMCCLM,me)
ENDIF
CALL QCMXMN('SMC1c ',SMCCLM(1,1),SLICLM,SNOCLM,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SMC2c ',SMCCLM(1,2),SLICLM,SNOCLM,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu [+8L] add smcclm(3:4)
IF(LSOIL.GT.2) THEN
CALL QCMXMN('SMC3c ',SMCCLM(1,3),SLICLM,SNOCLM,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SMC4c ',SMCCLM(1,4),SLICLM,SNOCLM,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
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,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('STC2c ',STCCLM(1,2),SLICLM,SNOCLM,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu [+8L] add stcclm(3:4)
IF(LSOIL.GT.2) THEN
CALL QCMXMN('STC3c ',STCCLM(1,3),SLICLM,SNOCLM,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('STC4c ',STCCLM(1,4),SLICLM,SNOCLM,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
CALL QCMXMN('VEGc ',VEGCLM,SLICLM,SNOCLM,icefl1,
& VEGLMX,VEGLMN,VEGOMX,VEGOMN,VEGIMX,VEGIMN,
& VEGJMX,VEGJMN,VEGSMX,VEGSMN,EPSVEG,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('VETc ',VETCLM,SLICLM,SNOCLM,icefl1,
& VETLMX,VETLMN,VETOMX,VETOMN,VETIMX,VETIMN,
& VETJMX,VETJMN,VETSMX,VETSMN,EPSVET,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SOTc ',SOTCLM,SLICLM,SNOCLM,icefl1,
& SOTLMX,SOTLMN,SOTOMX,SOTOMN,SOTIMX,SOTIMN,
& SOTJMX,SOTJMN,SOTSMX,SOTSMN,EPSSOT,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Cwu [+8L] ---------------------------------------------------------------
CALL QCMXMN('SIHc ',SIHCLM,SLICLM,SNOCLM,icefl1,
& 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)
!Clu [+16L] ---------------------------------------------------------------
CALL QCMXMN('VMNc ',VMNCLM,SLICLM,SNOCLM,icefl1,
& VMNLMX,VMNLMN,VMNOMX,VMNOMN,VMNIMX,VMNIMN,
& VMNJMX,VMNJMN,VMNSMX,VMNSMN,EPSVMN,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('VMXc ',VMXCLM,SLICLM,SNOCLM,icefl1,
& VMXLMX,VMXLMN,VMXOMX,VMXOMN,VMXIMX,VMXIMN,
& VMXJMX,VMXJMN,VMXSMX,VMXSMN,EPSVMX,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SLPc ',SLPCLM,SLICLM,SNOCLM,icefl1,
& SLPLMX,SLPLMN,SLPOMX,SLPOMN,SLPIMX,SLPIMN,
& SLPJMX,SLPJMN,SLPSMX,SLPSMN,EPSSLP,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('ABSc ',ABSCLM,SLICLM,SNOCLM,icefl1,
& ABSLMX,ABSLMN,ABSOMX,ABSOMN,ABSIMX,ABSIMN,
& ABSJMX,ABSJMN,ABSSMX,ABSSMN,EPSABS,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu ----------------------------------------------------------------------
!
! MONITORING PRINTS
!
IF (MONCLM) THEN
if (me .eq. 0) then
PRINT *,' '
PRINT *,'MONITOR OF TIME AND SPACE INTERPOLATED CLIMATOLOGY'
PRINT *,' '
! CALL COUNT(SLICLM,SNOCLM,LEN)
PRINT *,' '
CALL MONITR('TSFCLM',TSFCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('ALBCLM',ALBCLM(1,1),SLICLM,SNOCLM,LEN)
CALL MONITR('ALBCLM',ALBCLM(1,2),SLICLM,SNOCLM,LEN)
CALL MONITR('ALBCLM',ALBCLM(1,3),SLICLM,SNOCLM,LEN)
CALL MONITR('ALBCLM',ALBCLM(1,4),SLICLM,SNOCLM,LEN)
CALL MONITR('AISCLM',AISCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('SNOCLM',SNOCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('SCVCLM',SCVCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('SMCCLM1',SMCCLM(1,1),SLICLM,SNOCLM,LEN)
CALL MONITR('SMCCLM2',SMCCLM(1,2),SLICLM,SNOCLM,LEN)
CALL MONITR('STCCLM1',STCCLM(1,1),SLICLM,SNOCLM,LEN)
CALL MONITR('STCCLM2',STCCLM(1,2),SLICLM,SNOCLM,LEN)
!Clu [+4L] add smcclm(3:4) and stcclm(3:4)
IF(LSOIL.GT.2) THEN
CALL MONITR('SMCCLM3',SMCCLM(1,3),SLICLM,SNOCLM,LEN)
CALL MONITR('SMCCLM4',SMCCLM(1,4),SLICLM,SNOCLM,LEN)
CALL MONITR('STCCLM3',STCCLM(1,3),SLICLM,SNOCLM,LEN)
CALL MONITR('STCCLM4',STCCLM(1,4),SLICLM,SNOCLM,LEN)
ENDIF
CALL MONITR('TG3CLM',TG3CLM,SLICLM,SNOCLM,LEN)
CALL MONITR('ZORCLM',ZORCLM,SLICLM,SNOCLM,LEN)
! IF (GAUS) THEN
CALL MONITR('CVACLM',CVCLM ,SLICLM,SNOCLM,LEN)
CALL MONITR('CVBCLM',CVBCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('CVTCLM',CVTCLM,SLICLM,SNOCLM,LEN)
! ENDIF
CALL MONITR('SLICLM',SLICLM,SLICLM,SNOCLM,LEN)
! CALL MONITR('PLRCLM',PLRCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('OROG ',OROG ,SLICLM,SNOCLM,LEN)
CALL MONITR('VEGCLM',VEGCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('VETCLM',VETCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('SOTCLM',SOTCLM,SLICLM,SNOCLM,LEN)
!Cwu [+2L] add sih, sic
CALL MONITR('SIHCLM',SIHCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('SICCLM',SICCLM,SLICLM,SNOCLM,LEN)
!Clu [+4L] add vmn, vmx, slp, abs
CALL MONITR('VMNCLM',VMNCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('VMXCLM',VMXCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('SLPCLM',SLPCLM,SLICLM,SNOCLM,LEN)
CALL MONITR('ABSCLM',ABSCLM,SLICLM,SNOCLM,LEN)
endif
ENDIF
!
!
if (me .eq. 0) then
WRITE(6,*) '=============='
WRITE(6,*) ' ANALYSIS'
WRITE(6,*) '=============='
endif
!
! Fill in analysis array with climatology before reading analysis.
!
CALL 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)
!
! Reverse scaling to match with grib analysis input
!
ZSCA=0.01
CALL SCALE(ZORANL,LEN, ZSCA)
ZSCA=100.
CALL SCALE(ALBANL,LEN,ZSCA)
CALL SCALE(ALBANL(1,2),LEN,ZSCA)
CALL SCALE(ALBANL(1,3),LEN,ZSCA)
CALL SCALE(ALBANL(1,4),LEN,ZSCA)
CALL SCALE(ALFANL,LEN,ZSCA)
CALL SCALE(ALFANL(1,2),LEN,ZSCA)
!Clu [+4L] reverse scale for vmn, vmx, abs
ZSCA=100.
CALL SCALE(VMNANL,LEN,ZSCA)
CALL SCALE(VMXANL,LEN,ZSCA)
CALL SCALE(ABSANL,LEN,ZSCA)
!
PERCRIT=CRITP2
!
! READ ANALYSIS FIELDS
!
CALL 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,
& kpdvet,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, RLA, RLO, GAUSM, BLNMSK, BLTMSK,me)
! if(lprnt) print *,' tsfanl=',tsfanl(iprnt)
!
! Scale ZOR and ALB to match forecast model units
!
ZSCA=100.
CALL SCALE(ZORANL,LEN, ZSCA)
ZSCA=0.01
CALL SCALE(ALBANL,LEN,ZSCA)
CALL SCALE(ALBANL(1,2),LEN,ZSCA)
CALL SCALE(ALBANL(1,3),LEN,ZSCA)
CALL SCALE(ALBANL(1,4),LEN,ZSCA)
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
CALL SCALE(VMNANL,LEN,ZSCA)
CALL SCALE(VMXANL,LEN,ZSCA)
CALL SCALE(ABSANL,LEN,ZSCA)
!
! Interpolate climatology but fixing initial anomaly
!
IF(FH.GT.0.0.AND.FNTSFA(1:8).NE.' '.AND.LANOM) THEN
CALL ANOMINT(TSFAN0,TSFCLM,TSFCL0,TSFANL,LEN)
ENDIF
!
! If the TSFANL is at sea level, then bring it to the surface using
! unfiltered orography (for lakes). If the analysis is at lake surface
! as in the NST model, then this call should be removed - Moorthi 09/23/2011
!
if (use_ufo) then
ZTSFC = 0.0
CALL TSFCOR(TSFANL,OROG_uf,SLMASK,ZTSFC,LEN,RLAPSE)
endif
!
! Ice concentration or ice mask (only ice mask used in the model now)
!
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(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=0.5
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(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
DO I=1,LEN
IF((SLIANL(I).EQ.0.).AND.(SICANL(I).GE.CRIT)) THEN
SLIANL(I)=2.
! PRINT *,'cycle - NEW ICE FORM: FICE=',SICANL(I)
ELSE IF((SLIANL(I).GE.2.).AND.(SICANL(I).LT.CRIT)) THEN
SLIANL(I)=0.
! PRINT *,'cycle - ICE FREE: FICE=',SICANL(I)
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.
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) .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)
DO I=1,LEN
AISANL(I)=ACNANL(I)
ENDDO
ENDIF
! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir='
! &,glacir(iprnt),' slmask=',slmask(iprnt)
!
CALL QCSICE(AISANL,GLACIR,AMXICE,AICICE,AICSEA,SLLND,SLMASK,
& RLA,RLO,LEN,me)
!
! Set ocean/land/sea-ice mask
!
CALL SETLSI(SLMASK,AISANL,LEN,AICICE,SLIANL)
! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl='
! *,slianl(iprnt),' slmask=',slmask(iprnt)
!
!
do k=1,lsoil
do i=1,len
if (slianl(i) .eq. 0) then
smcanl(i,k) = smcomx
stcanl(i,k) = tsfanl(i)
endif
enddo
enddo
! WRITE(6,*) 'SLIANL'
! ZNNT=1.
! CALL NNTPRT(SLIANL,LEN,ZNNT)
!Cwu [+8L]----------------------------------------------------------------------
CALL QCMXMN('SIHa ',SIHANL,SLIANL,SNOANL,icefl1,
& 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)
!
! Set albedo over ocean to ALBOMX
!
CALL ALBOCN(ALBANL,SLMASK,ALBOMX,LEN)
!
! Quality control of snow and sea-ice
! Process snow depth or snow cover
!
IF(FNSNOA(1:8).NE.' ') THEN
CALL SETZRO(SNOANL,EPSSNO,LEN)
!cggg landice mods start
! CALL QCSNOW(SNOANL,SLMASK,AISANL,GLACIR,LEN,10.,me)
CALL QCSNOW(SNOANL,SLMASK,AISANL,GLACIR,LEN,ten,LANDICE,me)
!cggg landice mods end
!cggg landice mods start
! CALL SNODPTH2(GLACIR,SNOSMX,SNOANL, LEN, me)
IF (.NOT.LANDICE) THEN
CALL SNODPTH2(GLACIR,SNOSMX,SNOANL, LEN, me)
ENDIF
!cggg landice mods end
KQCM=1
CALL SNOSFC(SNOANL,TSFANL,TSFSMX,LEN,me)
CALL QCMXMN('Snoa ',SNOANL,SLIANL,SNOANL,icefl1,
& SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
& SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL GETSCV(SNOANL,SCVANL,LEN)
CALL QCMXMN('Sncva' ,SCVANL,SLIANL,SNOANL,icefl1,
& SCVLMX,SCVLMN,SCVOMX,SCVOMN,SCVIMX,SCVIMN,
& SCVJMX,SCVJMN,SCVSMX,SCVSMN,EPSSCV,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ELSE
CRIT=0.5
CALL ROF01(SCVANL,LEN,'GE',CRIT)
!cggg landice mods start
! CALL QCSNOW(SCVANL,SLMASK,AISANL,GLACIR,LEN,1.,me)
CALL QCSNOW(SCVANL,SLMASK,AISANL,GLACIR,LEN,one,LANDICE,me)
!cggg landice mods end
CALL QCMXMN('SNcva ',SCVANL,SLIANL,SCVANL,icefl1,
& SCVLMX,SCVLMN,SCVOMX,SCVOMN,SCVIMX,SCVIMN,
& SCVJMX,SCVJMN,SCVSMX,SCVSMN,EPSSCV,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!cggg landice mods start
! CALL SNODPTH(SCVANL,SLIANL,TSFANL,SNOCLM,
! & GLACIR,SNWMAX,SNWMIN,LEN,SNOANL,me)
CALL SNODPTH(SCVANL,SLIANL,TSFANL,SNOCLM,
& GLACIR,SNWMAX,SNWMIN,LANDICE,LEN,SNOANL,me)
!cggg landice mods end
!cggg landice mods start
! CALL QCSNOW(SCVANL,SLMASK,AISANL,GLACIR,LEN,SNOSMX,me)
CALL QCSNOW(SCVANL,SLMASK,AISANL,GLACIR,LEN,SNOSMX,LANDICE,me)
!cggg landice mods end
CALL SNOSFC(SNOANL,TSFANL,TSFSMX,LEN,me)
CALL QCMXMN('SNowa ',SNOANL,SLIANL,SNOANL,icefl1,
& SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
& SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
!
do i=1,len
icefl2(i) = sicanl(i) .gt. 0.99999
enddo
CALL QCMXMN('TSFa ',TSFANL,SLIANL,SNOANL,icefl2,
& TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
& TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
do kk = 1, 4
CALL QCMXMN('ALBa ',ALBANL(1,kk),SLIANL,SNOANL,icefl1,
& ALBLMX,ALBLMN,ALBOMX,ALBOMN,ALBIMX,ALBIMN,
& ALBJMX,ALBJMN,ALBSMX,ALBSMN,EPSALB,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
enddo
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,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
CALL QCMXMN('ZORa ',ZORANL,SLIANL,SNOANL,icefl1,
& ZORLMX,ZORLMN,ZOROMX,ZOROMN,ZORIMX,ZORIMN,
& ZORJMX,ZORJMN,ZORSMX,ZORSMN,EPSZOR,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! IF(FNPLRC(1:8).NE.' ' .OR. FNPLRA(1:8).NE.' ' ) THEN
! CALL QCMXMN('PLNa ',PLRANL,SLIANL,SNOANL,icefl1,
! & PLRLMX,PLRLMN,PLROMX,PLROMN,PLRIMX,PLRIMN,
! & PLRJMX,PLRJMN,PLRSMX,PLRSMN,EPSPLR,
! & RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! ENDIF
CALL QCMXMN('TG3a ',TG3ANL,SLIANL,SNOANL,icefl1,
& TG3LMX,TG3LMN,TG3OMX,TG3OMN,TG3IMX,TG3IMN,
& TG3JMX,TG3JMN,TG3SMX,TG3SMN,EPSTG3,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!
! Get soil temp and moisture
!
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,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SMC2a ',SMCANL(1,2),SLIANL,SNOANL,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu [+8L] add smcanl(3:4)
IF(LSOIL.GT.2) THEN
CALL QCMXMN('SMC3a ',SMCANL(1,3),SLIANL,SNOANL,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SMC4a ',SMCANL(1,4),SLIANL,SNOANL,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
IF(FNSTCA(1:8).EQ.' ') THEN
CALL GETSTC(TSFANL,TG3ANL,SLIANL,LEN,LSOIL,STCANL,TSFIMX)
ENDIF
CALL QCMXMN('STC1a ',STCANL(1,1),SLIANL,SNOANL,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('STC2a ',STCANL(1,2),SLIANL,SNOANL,icefl1,
& 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('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,
& VEGJMX,VEGJMN,VEGSMX,VEGSMN,EPSVEG,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('VETa ',VETANL,SLIANL,SNOANL,icefl1,
& VETLMX,VETLMN,VETOMX,VETOMN,VETIMX,VETIMN,
& VETJMX,VETJMN,VETSMX,VETSMN,EPSVET,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SOTa ',SOTANL,SLIANL,SNOANL,icefl1,
& SOTLMX,SOTLMN,SOTOMX,SOTOMN,SOTIMX,SOTIMN,
& SOTJMX,SOTJMN,SOTSMX,SOTSMN,EPSSOT,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu [+16L]----------------------------------------------------------------------
CALL QCMXMN('VMNa ',VMNANL,SLIANL,SNOANL,icefl1,
& VMNLMX,VMNLMN,VMNOMX,VMNOMN,VMNIMX,VMNIMN,
& VMNJMX,VMNJMN,VMNSMX,VMNSMN,EPSVMN,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('VMXa ',VMXANL,SLIANL,SNOANL,icefl1,
& VMXLMX,VMXLMN,VMXOMX,VMXOMN,VMXIMX,VMXIMN,
& VMXJMX,VMXJMN,VMXSMX,VMXSMN,EPSVMX,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SLPa ',SLPANL,SLIANL,SNOANL,icefl1,
& SLPLMX,SLPLMN,SLPOMX,SLPOMN,SLPIMX,SLPIMN,
& SLPJMX,SLPJMN,SLPSMX,SLPSMN,EPSSLP,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('ABSa ',ABSANL,SLIANL,SNOANL,icefl1,
& ABSLMX,ABSLMN,ABSOMX,ABSOMN,ABSIMX,ABSIMN,
& ABSJMX,ABSJMN,ABSSMX,ABSSMN,EPSABS,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu ----------------------------------------------------------------------------
!
! MONITORING PRINTS
!
IF (MONANL) THEN
if (me .eq. 0) then
PRINT *,' '
PRINT *,'MONITOR OF TIME AND SPACE INTERPOLATED ANALYSIS'
PRINT *,' '
! CALL COUNT(SLIANL,SNOANL,LEN)
PRINT *,' '
CALL MONITR('TSFANL',TSFANL,SLIANL,SNOANL,LEN)
CALL MONITR('ALBANL',ALBANL,SLIANL,SNOANL,LEN)
CALL MONITR('AISANL',AISANL,SLIANL,SNOANL,LEN)
CALL MONITR('SNOANL',SNOANL,SLIANL,SNOANL,LEN)
CALL MONITR('SCVANL',SCVANL,SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL1',SMCANL(1,1),SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL2',SMCANL(1,2),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL1',STCANL(1,1),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL2',STCANL(1,2),SLIANL,SNOANL,LEN)
!Clu [+4L] add smcanl(3:4) and stcanl(3:4)
IF(LSOIL.GT.2) THEN
CALL MONITR('SMCANL3',SMCANL(1,3),SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL4',SMCANL(1,4),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL3',STCANL(1,3),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL4',STCANL(1,4),SLIANL,SNOANL,LEN)
ENDIF
CALL MONITR('TG3ANL',TG3ANL,SLIANL,SNOANL,LEN)
CALL MONITR('ZORANL',ZORANL,SLIANL,SNOANL,LEN)
! IF (GAUS) THEN
CALL MONITR('CVAANL',CVANL ,SLIANL,SNOANL,LEN)
CALL MONITR('CVBANL',CVBANL,SLIANL,SNOANL,LEN)
CALL MONITR('CVTANL',CVTANL,SLIANL,SNOANL,LEN)
! ENDIF
CALL MONITR('SLIANL',SLIANL,SLIANL,SNOANL,LEN)
! CALL MONITR('PLRANL',PLRANL,SLIANL,SNOANL,LEN)
CALL MONITR('OROG ',OROG ,SLIANL,SNOANL,LEN)
CALL MONITR('VEGANL',VEGANL,SLIANL,SNOANL,LEN)
CALL MONITR('VETANL',VETANL,SLIANL,SNOANL,LEN)
CALL MONITR('SOTANL',SOTANL,SLIANL,SNOANL,LEN)
!Cwu [+2L] add sih, sic
CALL MONITR('SIHANL',SIHANL,SLIANL,SNOANL,LEN)
CALL MONITR('SICANL',SICANL,SLIANL,SNOANL,LEN)
!Clu [+4L] add vmn, vmx, slp, abs
CALL MONITR('VMNANL',VMNANL,SLIANL,SNOANL,LEN)
CALL MONITR('VMXANL',VMXANL,SLIANL,SNOANL,LEN)
CALL MONITR('SLPANL',SLPANL,SLIANL,SNOANL,LEN)
CALL MONITR('ABSANL',ABSANL,SLIANL,SNOANL,LEN)
endif
ENDIF
!
! Read in forecast fields if needed
!
if (me .eq. 0) then
WRITE(6,*) '=============='
WRITE(6,*) ' FCST GUESS'
WRITE(6,*) '=============='
endif
!
PERCRIT=CRITP2
!
IF(DEADS) THEN
!
! Fill in guess array with Analysis if dead start.
!
PERCRIT=CRITP3
if (me .eq. 0) WRITE(6,*) 'THIS RUN IS DEAD START RUN'
CALL 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)
IF(SIG1T(1).NE.0.) THEN
CALL USESGT(SIG1T,SLIANL,TG3ANL,LEN,LSOIL,TSFFCS,STCFCS,
& TSFIMX)
do i=1,len
icefl2(i) = sicfcs(i) .gt. 0.99999
enddo
KQCM=1
CALL QCMXMN('TSFf ',TSFFCS,SLIFCS,SNOFCS,icefl2,
& TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
& TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('STC1f ',STCFCS(1,1),SLIFCS,SNOFCS,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('STC2f ',STCFCS(1,2),SLIFCS,SNOFCS,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
ELSE
PERCRIT=CRITP2
!
! Make reverse angulation correction to TSF
! Make reverse orography correction to TG3
!
if (use_ufo) then
ZTSFC = 1.0
orogd = orog - orog_uf
CALL TSFCOR(TG3FCS,OROGd,SLMASK,ZTSFC,LEN,-RLAPSE)
ZTSFC = 0.
CALL TSFCOR(TSFFCS,OROGd,SLMASK,ZTSFC,LEN,-RLAPSE)
else
ZTSFC = 0.
CALL TSFCOR(TSFFCS,OROG,SLMASK,ZTSFC,LEN,-RLAPSE)
endif
!Clu [+12L] --------------------------------------------------------------
!
! Compute soil moisture liquid-to-total ratio over land
!
DO J=1, LSOIL
DO I=1, LEN
IF(SMCFCS(I,J) .NE. 0.) THEN
SWRATIO(I,J) = SLCFCS(I,J)/SMCFCS(I,J)
ELSE
SWRATIO(I,J) = -999.
ENDIF
ENDDO
ENDDO
!Clu -----------------------------------------------------------------------
!
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
CALL QCMXMN('Snof ',SNOFCS,SLIFCS,SNOFCS,icefl1,
& SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
& SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('TSFf ',TSFFCS,SLIFCS,SNOFCS,icefl2,
& TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
& TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
do kk = 1, 4
CALL QCMXMN('ALBf ',ALBFCS(1,kk),SLIFCS,SNOFCS,icefl1,
& ALBLMX,ALBLMN,ALBOMX,ALBOMN,ALBIMX,ALBIMN,
& ALBJMX,ALBJMN,ALBSMX,ALBSMN,EPSALB,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
enddo
IF(FNWETC(1:8).NE.' ' .OR. FNWETA(1:8).NE.' ' )
& THEN
CALL QCMXMN('WETf ',WETFCS,SLIFCS,SNOFCS,icefl1,
& WETLMX,WETLMN,WETOMX,WETOMN,WETIMX,WETIMN,
& WETJMX,WETJMN,WETSMX,WETSMN,EPSWET,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
CALL QCMXMN('ZORf ',ZORFCS,SLIFCS,SNOFCS,icefl1,
& ZORLMX,ZORLMN,ZOROMX,ZOROMN,ZORIMX,ZORIMN,
& ZORJMX,ZORJMN,ZORSMX,ZORSMN,EPSZOR,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! IF(FNPLRC(1:8).NE.' ' .OR. FNPLRA(1:8).NE.' ' )
! CALL QCMXMN('PLNf ',PLRFCS,SLIFCS,SNOFCS,icefl1,
! & PLRLMX,PLRLMN,PLROMX,PLROMN,PLRIMX,PLRIMN,
! & PLRJMX,PLRJMN,PLRSMX,PLRSMN,EPSPLR,
! & RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! ENDIF
CALL QCMXMN('TG3f ',TG3FCS,SLIFCS,SNOFCS,icefl1,
& TG3LMX,TG3LMN,TG3OMX,TG3OMN,TG3IMX,TG3IMN,
& TG3JMX,TG3JMN,TG3SMX,TG3SMN,EPSTG3,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Cwu [+8L] ---------------------------------------------------------------
CALL QCMXMN('SIHf ',SIHFCS,SLIFCS,SNOFCS,icefl1,
& 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('SMC1f ',SMCFCS(1,1),SLIFCS,SNOFCS,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SMC2f ',SMCFCS(1,2),SLIFCS,SNOFCS,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu [+8L] add smcfcs(3:4)
IF(LSOIL.GT.2) THEN
CALL QCMXMN('SMC3f ',SMCFCS(1,3),SLIFCS,SNOFCS,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SMC4f ',SMCFCS(1,4),SLIFCS,SNOFCS,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
CALL QCMXMN('STC1f ',STCFCS(1,1),SLIFCS,SNOFCS,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('STC2f ',STCFCS(1,2),SLIFCS,SNOFCS,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu [+8L] add stcfcs(3:4)
IF(LSOIL.GT.2) THEN
CALL QCMXMN('STC3f ',STCFCS(1,3),SLIFCS,SNOFCS,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('STC4f ',STCFCS(1,4),SLIFCS,SNOFCS,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
CALL QCMXMN('VEGf ',VEGFCS,SLIFCS,SNOFCS,icefl1,
& VEGLMX,VEGLMN,VEGOMX,VEGOMN,VEGIMX,VEGIMN,
& VEGJMX,VEGJMN,VEGSMX,VEGSMN,EPSVEG,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('VETf ',VETFCS,SLIFCS,SNOFCS,icefl1,
& VETLMX,VETLMN,VETOMX,VETOMN,VETIMX,VETIMN,
& VETJMX,VETJMN,VETSMX,VETSMN,EPSVET,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SOTf ',SOTFCS,SLIFCS,SNOFCS,icefl1,
& SOTLMX,SOTLMN,SOTOMX,SOTOMN,SOTIMX,SOTIMN,
& SOTJMX,SOTJMN,SOTSMX,SOTSMN,EPSSOT,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu [+16L] ---------------------------------------------------------------
CALL QCMXMN('VMNf ',VMNFCS,SLIFCS,SNOFCS,icefl1,
& VMNLMX,VMNLMN,VMNOMX,VMNOMN,VMNIMX,VMNIMN,
& VMNJMX,VMNJMN,VMNSMX,VMNSMN,EPSVMN,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('VMXf ',VMXFCS,SLIFCS,SNOFCS,icefl1,
& VMXLMX,VMXLMN,VMXOMX,VMXOMN,VMXIMX,VMXIMN,
& VMXJMX,VMXJMN,VMXSMX,VMXSMN,EPSVMX,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SLPf ',SLPFCS,SLIFCS,SNOFCS,icefl1,
& SLPLMX,SLPLMN,SLPOMX,SLPOMN,SLPIMX,SLPIMN,
& SLPJMX,SLPJMN,SLPSMX,SLPSMN,EPSSLP,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('ABSf ',ABSFCS,SLIFCS,SNOFCS,icefl1,
& ABSLMX,ABSLMN,ABSOMX,ABSOMN,ABSIMX,ABSIMN,
& ABSJMX,ABSJMN,ABSSMX,ABSSMN,EPSABS,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu -----------------------------------------------------------------------
ENDIF
ENDIF
!
IF (MONFCS) THEN
if (me .eq. 0) then
PRINT *,' '
PRINT *,'MONITOR OF GUESS'
PRINT *,' '
! CALL COUNT(SLIFCS,SNOFCS,LEN)
PRINT *,' '
CALL MONITR('TSFFCS',TSFFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('ALBFCS',ALBFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('AISFCS',AISFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('SNOFCS',SNOFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('SMCFCS1',SMCFCS(1,1),SLIFCS,SNOFCS,LEN)
CALL MONITR('SMCFCS2',SMCFCS(1,2),SLIFCS,SNOFCS,LEN)
CALL MONITR('STCFCS1',STCFCS(1,1),SLIFCS,SNOFCS,LEN)
CALL MONITR('STCFCS2',STCFCS(1,2),SLIFCS,SNOFCS,LEN)
!Clu [+4L] add smcfcs(3:4) and stcfcs(3:4)
IF(LSOIL.GT.2) THEN
CALL MONITR('SMCFCS3',SMCFCS(1,3),SLIFCS,SNOFCS,LEN)
CALL MONITR('SMCFCS4',SMCFCS(1,4),SLIFCS,SNOFCS,LEN)
CALL MONITR('STCFCS3',STCFCS(1,3),SLIFCS,SNOFCS,LEN)
CALL MONITR('STCFCS4',STCFCS(1,4),SLIFCS,SNOFCS,LEN)
ENDIF
CALL MONITR('TG3FCS',TG3FCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('ZORFCS',ZORFCS,SLIFCS,SNOFCS,LEN)
! IF (GAUS) THEN
CALL MONITR('CVAFCS',CVFCS ,SLIFCS,SNOFCS,LEN)
CALL MONITR('CVBFCS',CVBFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('CVTFCS',CVTFCS,SLIFCS,SNOFCS,LEN)
! ENDIF
CALL MONITR('SLIFCS',SLIFCS,SLIFCS,SNOFCS,LEN)
! CALL MONITR('PLRFCS',PLRFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('OROG ',OROG ,SLIFCS,SNOFCS,LEN)
CALL MONITR('VEGFCS',VEGFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('VETFCS',VETFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('SOTFCS',SOTFCS,SLIFCS,SNOFCS,LEN)
!Cwu [+2L] add sih, sic
CALL MONITR('SIHFCS',SIHFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('SICFCS',SICFCS,SLIFCS,SNOFCS,LEN)
!Clu [+4L] add vmn, vmx, slp, abs
CALL MONITR('VMNFCS',VMNFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('VMXFCS',VMXFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('SLPFCS',SLPFCS,SLIFCS,SNOFCS,LEN)
CALL MONITR('ABSFCS',ABSFCS,SLIFCS,SNOFCS,LEN)
endif
ENDIF
!
!... update annual cycle in the sst guess..
!
! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt)
! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt)
DO I=1,LEN
IF(SLIANL(I) .EQ. 0.0) THEN
TSFFCS(I)=TSFFCS(I) + (TSFCLM(I) - TSFCL2(I))
ENDIF
ENDDO
!
! Quality control analysis using forecast guess
!
CALL QCBYFC(TSFFCS,SNOFCS,QCTSFS,QCSNOS,QCTSFI,LEN,LSOIL,
& SNOANL,AISANL,SLIANL,TSFANL,ALBANL,
& ZORANL,SMCANL,
& SMCCLM,TSFSMX,ALBOMX,ZOROMX,me)
!
! BLEND CLIMATOLOGY AND PREDICTED FIELDS
!
if(me .eq. 0) then
WRITE(6,*) '=============='
WRITE(6,*) ' MERGING'
WRITE(6,*) '=============='
endif
! if(lprnt) print *,' tsffcs=',tsffcs(iprnt)
!
PERCRIT=CRITP3
!
! Merge analysis and forecast. Note TG3, AIS are not merged
!
CALL MERGE(LEN,LSOIL,IY,IM,ID,IH,FH,
!Cwu [+1L] add ()fcs for sih, sic
& SIHFCS,SICFCS,
!Clu [+1L] add ()fcs for vmn, vmx, slp, abs
& VMNFCS,VMXFCS,SLPFCS,ABSFCS,
& TSFFCS,WETFCS,SNOFCS,ZORFCS,ALBFCS,AISFCS,
& CVFCS ,CVBFCS,CVTFCS,
& CNPFCS,SMCFCS,STCFCS,SLIFCS,VEGFCS,
& vetfcs,sotfcs,alffcs,
!Cwu [+1L] add ()anl for sih, sic
& SIHANL,SICANL,
!Clu [+1L] add ()anl for vmn, vmx, slp, abs
& 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,
!Cwu [+1L] add c()l, c()s for sih, sic
& CSIHL,CSIHS,CSICL,CSICS,
!Clu [+1L] add c()l, c()s for vmn, vmx, slp, abs
& CVMNL,CVMNS,CVMXL,CVMXS,CSLPL,CSLPS,CABSL,CABSS,
& IRTTSF,IRTWET,IRTSNO,IRTZOR,IRTALB,IRTAIS,
& IRTTG3,IRTSCV,IRTACN,IRTSMC,IRTSTC,IRTVEG,
!Clu [+1L] add irt() for vmn, vmx, slp, abs
& IRTVMN,IRTVMX,IRTSLP,IRTABS,
!cggg landice start
!cggg & irtvet,irtsot,irtalf,me)
& irtvet,irtsot,irtalf,landice,me)
!cggg landice end
CALL SETZRO(SNOANL,EPSSNO,LEN)
! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt)
! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt)
!
! New ice/Melted ice
!
CALL NEWICE(SLIANL,SLIFCS,TSFANL,TSFFCS,LEN,LSOIL,
!Cwu [+1L] add SIHNEW, AISLIM, SIHANL & SICANL
& SIHNEW,AISLIM,SIHANL,SICANL,
& ALBANL,SNOANL,ZORANL,SMCANL,STCANL,
& ALBOMX,SNOOMX,ZOROMX,SMCOMX,SMCIMX,
!Cwu [-1L/+1L] change ALBIMX to ALBIMN - NOTE ALBIMX & ALBIMN have been modified
! & TSFOMN,TSFIMX,ALBIMX,ZORIMX,TGICE,
& TSFOMN,TSFIMX,ALBIMN,ZORIMX,TGICE,
& RLA,RLO,me)
! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt)
! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt)
!
! Set tsfc to TSNOW over snow
!
CALL SNOSFC(SNOANL,TSFANL,TSFSMX,LEN,me)
!
do i=1,len
icefl2(i) = sicanl(i) .gt. 0.99999
enddo
KQCM=0
CALL QCMXMN('SnowM ',SNOANL,SLIANL,SNOANL,icefl1,
& SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
& SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('TsfM ',TSFANL,SLIANL,SNOANL,icefl2,
& TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
& TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
do kk = 1, 4
CALL QCMXMN('AlbM ',ALBANL(1,kk),SLIANL,SNOANL,icefl1,
& ALBLMX,ALBLMN,ALBOMX,ALBOMN,ALBIMX,ALBIMN,
& ALBJMX,ALBJMN,ALBSMX,ALBSMN,EPSALB,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
enddo
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,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
ENDIF
CALL QCMXMN('ZorM ',ZORANL,SLIANL,SNOANL,icefl1,
& ZORLMX,ZORLMN,ZOROMX,ZOROMN,ZORIMX,ZORIMN,
& ZORJMX,ZORJMN,ZORSMX,ZORSMN,EPSZOR,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! IF(FNPLRC(1:8).NE.' ' .OR. FNPLRA(1:8).NE.' ' )
! & THEN
! CALL QCMXMN('PlntM ',PLRANL,SLIANL,SNOANL,icefl1,
! & PLRLMX,PLRLMN,PLROMX,PLROMN,PLRIMX,PLRIMN,
! & PLRJMX,PLRJMN,PLRSMX,PLRSMN,EPSPLR,
! & RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
! ENDIF
CALL QCMXMN('Stc1M ',STCANL(1,1),SLIANL,SNOANL,icefl1,
& STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
& STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('Stc2M ',STCANL(1,2),SLIANL,SNOANL,icefl1,
& 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,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('Smc2M ',SMCANL(1,2),SLIANL,SNOANL,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Clu [+8L] add smcanl(3:4)
IF(LSOIL.GT.2) THEN
CALL QCMXMN('Smc3M ',SMCANL(1,3),SLIANL,SNOANL,icefl1,
& SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
& SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
& 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
CALL QCMXMN('VEGm ',VEGANL,SLIANL,SNOANL,icefl1,
& VEGLMX,VEGLMN,VEGOMX,VEGOMN,VEGIMX,VEGIMN,
& VEGJMX,VEGJMN,VEGSMX,VEGSMN,EPSVEG,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('VETm ',VETANL,SLIANL,SNOANL,icefl1,
& VETLMX,VETLMN,VETOMX,VETOMN,VETIMX,VETIMN,
& VETJMX,VETJMN,VETSMX,VETSMN,EPSVET,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SOTm ',SOTANL,SLIANL,SNOANL,icefl1,
& SOTLMX,SOTLMN,SOTOMX,SOTOMN,SOTIMX,SOTIMN,
& SOTJMX,SOTJMN,SOTSMX,SOTSMN,EPSSOT,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!Cwu [+8L] add sih, sic,
CALL QCMXMN('SIHm ',SIHANL,SLIANL,SNOANL,icefl1,
& 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)
!Clu [+16L] add vmn, vmx, slp, abs
CALL QCMXMN('VMNm ',VMNANL,SLIANL,SNOANL,icefl1,
& VMNLMX,VMNLMN,VMNOMX,VMNOMN,VMNIMX,VMNIMN,
& VMNJMX,VMNJMN,VMNSMX,VMNSMN,EPSVMN,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('VMXm ',VMXANL,SLIANL,SNOANL,icefl1,
& VMXLMX,VMXLMN,VMXOMX,VMXOMN,VMXIMX,VMXIMN,
& VMXJMX,VMXJMN,VMXSMX,VMXSMN,EPSVMX,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('SLPm ',SLPANL,SLIANL,SNOANL,icefl1,
& SLPLMX,SLPLMN,SLPOMX,SLPOMN,SLPIMX,SLPIMN,
& SLPJMX,SLPJMN,SLPSMX,SLPSMN,EPSSLP,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
CALL QCMXMN('ABSm ',ABSANL,SLIANL,SNOANL,icefl1,
& ABSLMX,ABSLMN,ABSOMX,ABSOMN,ABSIMX,ABSIMN,
& ABSJMX,ABSJMN,ABSSMX,ABSSMN,EPSABS,
& RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
!
if(me .eq. 0) then
WRITE(6,*) '=============='
WRITE(6,*) 'FINAL RESULTS'
WRITE(6,*) '=============='
endif
!
! Foreward correction to TG3 and TSF at the last stage
!
! if(lprnt) print *,' tsfbc=',tsfanl(iprnt)
if (use_ufo) then
ZTSFC = 1.
CALL TSFCOR(TG3ANL,OROGd,SLMASK,ZTSFC,LEN,RLAPSE)
ZTSFC = 0.
CALL TSFCOR(TSFANL,OROGd,SLMASK,ZTSFC,LEN,RLAPSE)
else
ZTSFC = 0.
CALL TSFCOR(TSFANL,OROG,SLMASK,ZTSFC,LEN,RLAPSE)
endif
! if(lprnt) print *,' tsfaf=',tsfanl(iprnt)
!
! CHECK THE FINAL MERGED PRODUCT
!
IF (MONMER) THEN
if(me .eq. 0) then
PRINT *,' '
PRINT *,'MONITOR OF UPDATED SURFACE FIELDS'
PRINT *,' (Includes angulation correction)'
PRINT *,' '
! CALL COUNT(SLIANL,SNOANL,LEN)
PRINT *,' '
CALL MONITR('TSFANL',TSFANL,SLIANL,SNOANL,LEN)
CALL MONITR('ALBANL',ALBANL,SLIANL,SNOANL,LEN)
CALL MONITR('AISANL',AISANL,SLIANL,SNOANL,LEN)
CALL MONITR('SNOANL',SNOANL,SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL1',SMCANL(1,1),SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL2',SMCANL(1,2),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL1',STCANL(1,1),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL2',STCANL(1,2),SLIANL,SNOANL,LEN)
!Clu [+4L] add smcanl(3:4) and stcanl(3:4)
IF(LSOIL.GT.2) THEN
CALL MONITR('SMCANL3',SMCANL(1,3),SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL4',SMCANL(1,4),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL3',STCANL(1,3),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL4',STCANL(1,4),SLIANL,SNOANL,LEN)
CALL MONITR('TG3ANL',TG3ANL,SLIANL,SNOANL,LEN)
CALL MONITR('ZORANL',ZORANL,SLIANL,SNOANL,LEN)
ENDIF
! IF (GAUS) THEN
CALL MONITR('CVAANL',CVANL ,SLIANL,SNOANL,LEN)
CALL MONITR('CVBANL',CVBANL,SLIANL,SNOANL,LEN)
CALL MONITR('CVTANL',CVTANL,SLIANL,SNOANL,LEN)
! ENDIF
CALL MONITR('SLIANL',SLIANL,SLIANL,SNOANL,LEN)
! CALL MONITR('PLRANL',PLRANL,SLIANL,SNOANL,LEN)
CALL MONITR('OROG ',OROG ,SLIANL,SNOANL,LEN)
CALL MONITR('CNPANL',CNPANL,SLIANL,SNOANL,LEN)
CALL MONITR('VEGANL',VEGANL,SLIANL,SNOANL,LEN)
CALL MONITR('VETANL',VETANL,SLIANL,SNOANL,LEN)
CALL MONITR('SOTANL',SOTANL,SLIANL,SNOANL,LEN)
!Cwu [+2L] add sih, sic,
CALL MONITR('SIHANL',SIHANL,SLIANL,SNOANL,LEN)
CALL MONITR('SICANL',SICANL,SLIANL,SNOANL,LEN)
!Clu [+4L] add vmn, vmx, slp, abs
CALL MONITR('VMNANL',VMNANL,SLIANL,SNOANL,LEN)
CALL MONITR('VMXANL',VMXANL,SLIANL,SNOANL,LEN)
CALL MONITR('SLPANL',SLPANL,SLIANL,SNOANL,LEN)
CALL MONITR('ABSANL',ABSANL,SLIANL,SNOANL,LEN)
endif
ENDIF
!
IF (MONDIF) THEN
DO I=1,LEN
TSFFCS(I) = TSFANL(I) - TSFFCS(I)
SNOFCS(I) = SNOANL(I) - SNOFCS(I)
TG3FCS(I) = TG3ANL(I) - TG3FCS(I)
ZORFCS(I) = ZORANL(I) - ZORFCS(I)
! PLRFCS(I) = PLRANL(I) - PLRFCS(I)
! ALBFCS(I) = ALBANL(I) - ALBFCS(I)
SLIFCS(I) = SLIANL(I) - SLIFCS(I)
AISFCS(I) = AISANL(I) - AISFCS(I)
CNPFCS(I) = CNPANL(I) - CNPFCS(I)
VEGFCS(I) = VEGANL(I) - VEGFCS(I)
VETFCS(I) = VETANL(I) - VETFCS(I)
SOTFCS(I) = SOTANL(I) - SOTFCS(I)
!Clu [+2L] add sih, sic
SIHFCS(I) = SIHANL(I) - SIHFCS(I)
SICFCS(I) = SICANL(I) - SICFCS(I)
!Clu [+4L] add vmn, vmx, slp, abs
VMNFCS(I) = VMNANL(I) - VMNFCS(I)
VMXFCS(I) = VMXANL(I) - VMXFCS(I)
SLPFCS(I) = SLPANL(I) - SLPFCS(I)
ABSFCS(I) = ABSANL(I) - ABSFCS(I)
ENDDO
DO J = 1,LSOIL
DO I = 1,LEN
SMCFCS(I,J) = SMCANL(I,J) - SMCFCS(I,J)
STCFCS(I,J) = STCANL(I,J) - STCFCS(I,J)
ENDDO
ENDDO
DO J = 1,4
DO I = 1,LEN
ALBFCS(I,J) = ALBANL(I,J) - ALBFCS(I,J)
ENDDO
ENDDO
!
! MONITORING PRINTS
!
if(me .eq. 0) then
PRINT *,' '
PRINT *,'MONITOR OF DIFFERENCE'
PRINT *,' (Includes angulation correction)'
PRINT *,' '
CALL MONITR('TSFDIF',TSFFCS,SLIANL,SNOANL,LEN)
CALL MONITR('ALBDIF',ALBFCS,SLIANL,SNOANL,LEN)
CALL MONITR('ALBDIF1',ALBFCS,SLIANL,SNOANL,LEN)
CALL MONITR('ALBDIF2',ALBFCS(1,2),SLIANL,SNOANL,LEN)
CALL MONITR('ALBDIF3',ALBFCS(1,3),SLIANL,SNOANL,LEN)
CALL MONITR('ALBDIF4',ALBFCS(1,4),SLIANL,SNOANL,LEN)
CALL MONITR('AISDIF',AISFCS,SLIANL,SNOANL,LEN)
CALL MONITR('SNODIF',SNOFCS,SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL1',SMCFCS(1,1),SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL2',SMCFCS(1,2),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL1',STCFCS(1,1),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL2',STCFCS(1,2),SLIANL,SNOANL,LEN)
!Clu [+4L] add smcfcs(3:4) and stc(3:4)
IF(LSOIL.GT.2) THEN
CALL MONITR('SMCANL3',SMCFCS(1,3),SLIANL,SNOANL,LEN)
CALL MONITR('SMCANL4',SMCFCS(1,4),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL3',STCFCS(1,3),SLIANL,SNOANL,LEN)
CALL MONITR('STCANL4',STCFCS(1,4),SLIANL,SNOANL,LEN)
ENDIF
CALL MONITR('TG3DIF',TG3FCS,SLIANL,SNOANL,LEN)
CALL MONITR('ZORDIF',ZORFCS,SLIANL,SNOANL,LEN)
! IF (GAUS) THEN
CALL MONITR('CVADIF',CVFCS ,SLIANL,SNOANL,LEN)
CALL MONITR('CVBDIF',CVBFCS,SLIANL,SNOANL,LEN)
CALL MONITR('CVTDIF',CVTFCS,SLIANL,SNOANL,LEN)
! ENDIF
CALL MONITR('SLIDIF',SLIFCS,SLIANL,SNOANL,LEN)
! CALL MONITR('PLRDIF',PLRFCS,SLIANL,SNOANL,LEN)
CALL MONITR('CNPDIF',CNPFCS,SLIANL,SNOANL,LEN)
CALL MONITR('VEGDIF',VEGFCS,SLIANL,SNOANL,LEN)
CALL MONITR('VETDIF',VETFCS,SLIANL,SNOANL,LEN)
CALL MONITR('SOTDIF',SOTFCS,SLIANL,SNOANL,LEN)
!Cwu [+2L] add sih, sic
CALL MONITR('SIHDIF',SIHFCS,SLIANL,SNOANL,LEN)
CALL MONITR('SICDIF',SICFCS,SLIANL,SNOANL,LEN)
!Clu [+4L] add vmn, vmx, slp, abs
CALL MONITR('VMNDIF',VMNFCS,SLIANL,SNOANL,LEN)
CALL MONITR('VMXDIF',VMXFCS,SLIANL,SNOANL,LEN)
CALL MONITR('SLPDIF',SLPFCS,SLIANL,SNOANL,LEN)
CALL MONITR('ABSDIF',ABSFCS,SLIANL,SNOANL,LEN)
endif
ENDIF
!
!
DO I=1,LEN
TSFFCS(I) = TSFANL(I)
SNOFCS(I) = SNOANL(I)
TG3FCS(I) = TG3ANL(I)
ZORFCS(I) = ZORANL(I)
! PLRFCS(I) = PLRANL(I)
! ALBFCS(I) = ALBANL(I)
SLIFCS(I) = SLIANL(I)
AISFCS(I) = AISANL(I)
CVFCS(I) = CVANL(I)
CVBFCS(I) = CVBANL(I)
CVTFCS(I) = CVTANL(I)
CNPFCS(I) = CNPANL(I)
vegFCS(I) = vegANL(I)
vetFCS(I) = vetANL(I)
sotFCS(I) = sotANL(I)
!Clu [+4L] add vmn, vmx, slp, abs
VMNFCS(I) = VMNANL(I)
VMXFCS(I) = VMXANL(I)
SLPFCS(I) = SLPANL(I)
ABSFCS(I) = ABSANL(I)
ENDDO
DO J = 1,LSOIL
DO I = 1,LEN
SMCFCS(I,J) = SMCANL(I,J)
IF (SLIFCS(I) .GT. 0.0) THEN
STCFCS(I,J) = STCANL(I,J)
ELSE
STCFCS(I,J) = TSFFCS(I)
ENDIF
ENDDO
ENDDO
DO J = 1,4
DO I = 1,LEN
ALBFCS(I,J) = ALBANL(I,J)
ENDDO
ENDDO
DO J = 1,2
DO I = 1,LEN
ALFFCS(I,J) = ALFANL(I,J)
ENDDO
ENDDO
!Cwu [+20L] update SIHFCS, SICFCS. Remove sea ice over non-ice points
CRIT=AISLIM
DO I=1,LEN
SIHFCS(I) = SIHANL(I)
SITFCS(I) = TSFFCS(I)
IF (SLIFCS(I).GE.2.) THEN
IF (SICFCS(I).GT.CRIT) THEN
TSFFCS(I) = (SICANL(I)*TSFFCS(I)
& + (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
SIHFCS(I) = SIHNEW
ENDIF
ENDIF
SICFCS(I) = SICANL(I)
ENDDO
DO I=1,LEN
IF (SLIFCS(I).LT.1.5) THEN
SIHFCS(I) = 0.
SICFCS(I) = 0.
SITFCS(I) = TSFFCS(I)
ELSE IF ((SLIFCS(I).GE.1.5).AND.(SICFCS(I).LT.CRIT)) THEN
PRINT *,'WARNING: CHECK, SLIFCS and SICFCS',
& SLIFCS(I),SICFCS(I)
ENDIF
ENDDO
!Clu [+44L]--------------------------------------------------------------------
!
! ensure the consistency between slc and smc
!
DO K=1, LSOIL
FIXRATIO(K) = .False.
IF (FSMCL(K).LT.99999.) FIXRATIO(K) = .True.
ENDDO
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) .EQ. -999.) THEN
SLCFCS(I,K) = SMCFCS(I,K)
ELSE
SLCFCS(I,K) = SWRATIO(I,K) * SMCFCS(I,K)
ENDIF
!cggg
if (slifcs(i) .ne. 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points.
ENDDO
ENDIF
ENDDO
!cggg landice start
!cggg set liquid soil moisture to a flag value of 1.0
IF (LANDICE) THEN
DO I = 1, LEN
IF (SLIFCS(I) .EQ. 1.0 .AND. VETFCS(I) == 13.0) THEN
DO K=1, LSOIL
SLCFCS(I,K) = 1.0
ENDDO
ENDIF
ENDDO
END IF
!cggg landice end
!
! ensure the consistency between snwdph and sheleg
!
IF(FSNOL .LT. 99999.) THEN
if(me .eq. 0) then
print *,'DBGX -- scale snwdph from sheleg'
endif
DO I = 1, LEN
IF(SLIFCS(I).EQ.1.) SWDFCS(I) = 10.* SNOFCS(I)
ENDDO
ENDIF
! sea ice model only uses the liquid equivalent depth.
! so update the physical depth only for display purposes.
! use the same 3:1 ratio used by ice model.
do i = 1, len
if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i)
enddo
DO I = 1, LEN
IF(SLIFCS(I).EQ.1.) THEN
IF(SNOFCS(I).NE.0. .AND. SWDFCS(I).EQ.0.) THEN
print *,'DBGX --scale snwdph from sheleg',
+ I, SWDFCS(I), SNOFCS(I)
SWDFCS(I) = 10.* SNOFCS(I)
ENDIF
ENDIF
ENDDO
!cggg landice mods start - impose same minimum snow depth at
!cggg landice as noah lsm. also ensure
!cggg lower thermal boundary condition
!cggg and skin t is no warmer than freezing
!cggg after adjustment to terrain.
IF (LANDICE) THEN
DO I = 1, LEN
IF (SLIFCS(I) .EQ. 1.0 .AND. VETFCS(I) == 13.0) THEN
SNOFCS(I) = MAX(SNOFCS(I),100.0) ! IN MM
SWDFCS(I) = MAX(SWDFCS(I),1000.0) ! IN MM
TG3FCS(I) = MIN(TG3FCS(I),273.15)
TSFFCS(I) = MIN(TSFFCS(I),273.15)
ENDIF
ENDDO
END IF
!cggg landice mods end
!Clu---------------------------------------------------------------------------
!
! if(lprnt) print *,' tsffcsF=',tsffcs(iprnt)
RETURN
END SUBROUTINE SFCCYCLE
SUBROUTINE COUNT(SLIMSK,SNO,IJMAX)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
real (kind=kind_io8) rl3,rl1,rl0,rl2,rl6,rl7,rl4,rl5
integer l8,l7,l1,l2,ijmax,l0,l3,l5,l6,l4,ij
!
REAL (KIND=KIND_IO8) SLIMSK(1),SNO(1)
!
! COUNT NUMBER OF POINTS FOR THE FOUR SURFACE CONDITIONS
!
L0 = 0
L1 = 0
L2 = 0
L3 = 0
L4 = 0
DO IJ=1,IJMAX
IF(SLIMSK(IJ).EQ.0.) L1 = L1 + 1
IF(SLIMSK(IJ).EQ.1. .AND. SNO(IJ).LE.0.) L0 = L0 + 1
IF(SLIMSK(IJ).EQ.2. .AND. SNO(IJ).LE.0.) L2 = L2 + 1
IF(SLIMSK(IJ).EQ.1. .AND. SNO(IJ).GT.0.) L3 = L3 + 1
IF(SLIMSK(IJ).EQ.2. .AND. SNO(IJ).GT.0.) L4 = L4 + 1
ENDDO
L5 = L0 + L3
L6 = L2 + L4
L7 = L1 + L6
L8 = L1 + L5 + L6
RL0 = FLOAT(L0) / FLOAT(L8)*100.
RL3 = FLOAT(L3) / FLOAT(L8)*100.
RL1 = FLOAT(L1) / FLOAT(L8)*100.
RL2 = FLOAT(L2) / FLOAT(L8)*100.
RL4 = FLOAT(L4) / FLOAT(L8)*100.
RL5 = FLOAT(L5) / FLOAT(L8)*100.
RL6 = FLOAT(L6) / FLOAT(L8)*100.
RL7 = FLOAT(L7) / FLOAT(L8)*100.
PRINT *,'1) NO. OF NOT SNOW-COVERED LAND POINTS ',L0,' ',RL0,' '
PRINT *,'2) NO. OF SNOW COVERED LAND POINTS ',L3,' ',RL3,' '
PRINT *,'3) NO. OF OPEN SEA POINTS ',L1,' ',RL1,' '
PRINT *,'4) NO. OF NOT SNOW-COVERED SEAICE POINTS ',L2,' ',RL2,' '
PRINT *,'5) NO. OF SNOW COVERED SEA ICE POINTS ',L4,' ',RL4,' '
PRINT *,' '
PRINT *,'6) NO. OF LAND POINTS ',L5,' ',RL5,' '
PRINT *,'7) NO. SEA POINTS (INCLUDING SEA ICE) ',L7,' ',RL7,' '
PRINT *,' (NO. OF SEA ICE POINTS) (',L6,')',' ',RL6,' '
PRINT *,' '
PRINT *,'9) NO. OF TOTAL GRID POINTS ',L8
! PRINT *,' '
! PRINT *,' '
!
! if(lprnt) print *,' tsffcsF=',tsffcs(iprnt)
RETURN
END
SUBROUTINE MONITR(LFLD,FLD,SLIMSK,SNO,IJMAX)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer ij,n,ijmax
!
REAL (KIND=KIND_IO8) FLD(IJMAX), SLIMSK(IJMAX),SNO(IJMAX)
!
REAL (KIND=KIND_IO8) RMAX(5),RMIN(5)
CHARACTER*8 LFLD
!
! FIND MAX/MIN
!
DO N=1,5
RMAX(N) = -9.E20
RMIN(N) = 9.E20
ENDDO
!
DO IJ=1,IJMAX
IF(SLIMSK(IJ).EQ.0.) THEN
RMAX(1) = MAX(RMAX(1), FLD(IJ))
RMIN(1) = MIN(RMIN(1), FLD(IJ))
ELSEIF(SLIMSK(IJ).EQ.1.) THEN
IF(SNO(IJ).LE.0.) THEN
RMAX(2) = MAX(RMAX(2), FLD(IJ))
RMIN(2) = MIN(RMIN(2), FLD(IJ))
ELSE
RMAX(4) = MAX(RMAX(4), FLD(IJ))
RMIN(4) = MIN(RMIN(4), FLD(IJ))
ENDIF
ELSE
IF(SNO(IJ).LE.0.) THEN
RMAX(3) = MAX(RMAX(3), FLD(IJ))
RMIN(3) = MIN(RMIN(3), FLD(IJ))
ELSE
RMAX(5) = MAX(RMAX(5), FLD(IJ))
RMIN(5) = MIN(RMIN(5), FLD(IJ))
ENDIF
ENDIF
ENDDO
!
PRINT 100,LFLD
PRINT 101,RMAX(1),RMIN(1)
PRINT 102,RMAX(2),RMIN(2), RMAX(4), RMIN(4)
PRINT 103,RMAX(3),RMIN(3), RMAX(5), RMIN(5)
!
! PRINT 102,RMAX(2),RMIN(2)
! PRINT 103,RMAX(3),RMIN(3)
! PRINT 104,RMAX(4),RMIN(4)
! PRINT 105,RMAX(5),RMIN(5)
100 FORMAT('0 *** ',A8,' ***')
101 FORMAT(' OPEN SEA ......... MAX=',E12.4,' MIN=',E12.4)
102 FORMAT(' LAND NOSNOW/SNOW .. MAX=',E12.4,' MIN=',E12.4
&, ' MAX=',E12.4,' MIN=',E12.4)
103 FORMAT(' SEAICE NOSNOW/SNOW MAX=',E12.4,' MIN=',E12.4
&, ' MAX=',E12.4,' MIN=',E12.4)
!
! 100 FORMAT('0',2X,'*** ',A8,' ***')
! 102 FORMAT(2X,' LAND WITHOUT SNOW ..... MAX=',E12.4,' MIN=',E12.4)
! 103 FORMAT(2X,' SEAICE WITHOUT SNOW ... MAX=',E12.4,' MIN=',E12.4)
! 104 FORMAT(2X,' LAND WITH SNOW ........ MAX=',E12.4,' MIN=',E12.4)
! 105 FORMAT(2X,' SEA ICE WITH SNOW ..... MAX=',E12.4,' MIN=',E12.4)
!
RETURN
END
SUBROUTINE DAYOYR(IYR,IMO,IDY,LDY)
implicit none
integer ldy,i,idy,iyr,imo
!
! THIS ROUTINE FIGURES OUT THE DAY OF THE YEAR GIVEN IMO AND IDY
!
INTEGER MONTH(13)
DATA MONTH/0,31,28,31,30,31,30,31,31,30,31,30,31/
IF(MOD(IYR,4).EQ.0) MONTH(3) = 29
LDY = IDY
DO I = 1, IMO
LDY = LDY + MONTH(I)
ENDDO
RETURN
END
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
implicit none
integer kpds5,me,i,imsk,jmsk,lugb
!
CHARACTER*500 FNMSKH
!
REAL (KIND=KIND_IO8) SLMSKH(mdata)
LOGICAL GAUSM
REAL (KIND=KIND_IO8) BLNMSK,BLTMSK
!
IMSK = xdata
JMSK = ydata
if (me .eq. 0) then
write(6,*)' IMSK=',IMSK,' JMSK=',JMSK,' xdata=',xdata,' ydata='
&,ydata
endif
CALL FIXRDG(LUGB,IMSK,JMSK,FNMSKH,
& KPDS5,SLMSKH,GAUSM,BLNMSK,BLTMSK,me)
DO I=1,IMSK*JMSK
SLMSKH(I) = NINT(SLMSKH(I))
ENDDO
!
RETURN
END
SUBROUTINE FIXRDG(LUGB,IDIM,JDIM,FNGRIB,
& KPDS5,GDATA,GAUS,BLNO,BLTO,me)
USE MACHINE , ONLY : kind_io8,kind_io4
use sfccyc_module, only : mdata
implicit none
integer lgrib,n,lskip,jret,j,ndata,lugi,jdim,idim,lugb,
& iret, me,kpds5,kdata,i
!
CHARACTER*(*) FNGRIB
!
REAL (KIND=KIND_IO8) GDATA(IDIM*JDIM)
LOGICAL GAUS
REAL (KIND=KIND_IO8) BLNO,BLTO
real(kind=kind_io8) data4(idim*jdim)
!
LOGICAL*1 LBMS(mdata)
!
INTEGER KPDS(200),KGDS(200)
INTEGER JPDS(200),JGDS(200), KPDS0(200)
!
! if(me .eq. 0) then
! WRITE(6,*) ' '
! WRITE(6,*) '************************************************'
! endif
!
CLOSE(LUGB)
call baopenr(lugb,fngrib,iret)
IF (IRET .NE. 0) THEN
WRITE(6,*) ' ERROR IN OPENING FILE ',trim(FNGRIB)
PRINT *,'ERROR IN OPENING FILE ',trim(FNGRIB)
CALL ABORT
ENDIF
if (me .eq. 0) WRITE(6,*) ' FILE ',trim(FNGRIB),
& ' opened. Unit=',LUGB
lugi = 0
lskip = -1
N = 0
JPDS = -1
JGDS = -1
JPDS(5) = KPDS5
KPDS = JPDS
!
call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata,
& lskip,kpds,kgds,iret)
!
if(me .eq. 0) then
WRITE(6,*) ' First grib record.'
WRITE(6,*) ' KPDS( 1-10)=',(KPDS(J),J= 1,10)
WRITE(6,*) ' KPDS(11-20)=',(KPDS(J),J=11,20)
WRITE(6,*) ' KPDS(21- )=',(KPDS(J),J=21,22)
endif
!
KPDS0=JPDS
KPDS0(4)=-1
KPDS0(18)=-1
IF(IRET.NE.0) THEN
WRITE(6,*) ' Error in GETGBH. IRET: ', iret
IF (IRET == 99) WRITE(6,*) ' Field not found.'
CALL ABORT
ENDIF
!
jpds = kpds0
lskip = -1
kdata=idim*jdim
call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip,
& kpds,kgds,lbms,data4,jret)
!
if(jret.eq.0) then
IF(NDATA.EQ.0) THEN
WRITE(6,*) ' Error in getgb'
WRITE(6,*) ' KPDS=',KPDS
WRITE(6,*) ' KGDS=',KGDS
CALL ABORT
ENDIF
IDIM=KGDS(2)
JDIM=KGDS(3)
gaus=kgds(1).eq.4
blno=kgds(5)*1.d-3
blto=kgds(4)*1.d-3
gdata(1:idim*jdim)=data4(1:idim*jdim)
if (me .eq. 0) WRITE(6,*) 'IDIM,JDIM=',IDIM,JDIM
&, ' gaus=',gaus,' blno=',blno,' blto=',blto
ELSE
if (me .eq. 0) WRITE(6,*) 'IDIM,JDIM=',IDIM,JDIM
&, ' gaus=',gaus,' blno=',blno,' blto=',blto
WRITE(6,*) ' Error in GETGB : JRET=',JRET
WRITE(6,*) ' KPDS(13)=',KPDS(13),' KPDS(15)=',KPDS(15)
CALL ABORT
ENDIF
!
RETURN
END
SUBROUTINE GETAREA(KGDS,DLAT,DLON,RSLAT,RNLAT,WLON,ELON,IJORDR
&, me)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer j,me,kgds11
real (kind=kind_io8) f0lon,f0lat,elon,dlon,dlat,rslat,wlon,rnlat
!
! Get area of the grib record
!
Integer KGDS(22)
LOGICAL IJORDR
!
if (me .eq. 0) then
WRITE(6,*) ' KGDS( 1-12)=',(KGDS(J),J= 1,12)
WRITE(6,*) ' KGDS(13-22)=',(KGDS(J),J=13,22)
endif
!
IF(KGDS(1).EQ.0) THEN ! Lat/Lon grid
!
if (me .eq. 0) WRITE(6,*) 'LAT/LON GRID'
DLAT = FLOAT(KGDS(10)) * 0.001
DLON = FLOAT(KGDS( 9)) * 0.001
F0LON = FLOAT(KGDS(5)) * 0.001
F0LAT = FLOAT(KGDS(4)) * 0.001
KGDS11 = KGDS(11)
IF(KGDS11.GE.128) THEN
WLON = F0LON - DLON*(KGDS(2)-1)
ELON = F0LON
IF(DLON*KGDS(2).GT.359.99) THEN
WLON =F0LON - DLON*KGDS(2)
ENDIF
DLON = -DLON
KGDS11 = KGDS11 - 128
ELSE
WLON = F0LON
ELON = F0LON + DLON*(KGDS(2)-1)
IF(DLON*KGDS(2).GT.359.99) THEN
ELON = F0LON + DLON*KGDS(2)
ENDIF
ENDIF
IF(KGDS11.GE.64) THEN
RNLAT = F0LAT + DLAT*(KGDS(3)-1)
RSLAT = F0LAT
KGDS11 = KGDS11 - 64
ELSE
RNLAT = F0LAT
RSLAT = F0LAT - DLAT*(KGDS(3)-1)
DLAT = -DLAT
ENDIF
IF(KGDS11.GE.32) THEN
IJORDR = .FALSE.
ELSE
IJORDR = .TRUE.
ENDIF
IF(WLON.GT.180.) WLON = WLON - 360.
IF(ELON.GT.180.) ELON = ELON - 360.
WLON = NINT(WLON*1000.) * 0.001
ELON = NINT(ELON*1000.) * 0.001
RSLAT = NINT(RSLAT*1000.) * 0.001
RNLAT = NINT(RNLAT*1000.) * 0.001
RETURN
!
ELSEIF(KGDS(1).EQ.1) THEN ! Mercator projection
WRITE(6,*) 'Mercator GRID'
WRITE(6,*) 'Cannot process'
CALL ABORT
!
ELSEIF(KGDS(1).EQ.2) THEN ! Gnomonic projection
WRITE(6,*) 'Gnomonic GRID'
WRITE(6,*) 'ERROR!! Gnomonic projection not coded'
CALL ABORT
!
ELSEIF(KGDS(1).EQ.3) THEN ! Lambert conformal
WRITE(6,*) 'Lambert conformal'
WRITE(6,*) 'Cannot process'
CALL ABORT
ELSEIF(KGDS(1).EQ.4) THEN ! Gaussian grid
!
if (me .eq. 0) WRITE(6,*) 'Gaussian GRID'
DLAT = 99.
DLON = FLOAT(KGDS( 9)) / 1000.0
F0LON = FLOAT(KGDS(5)) / 1000.0
F0LAT = 99.
KGDS11 = KGDS(11)
IF(KGDS11.GE.128) THEN
WLON = F0LON
ELON = F0LON
IF(DLON*KGDS(2).GT.359.99) THEN
WLON = F0LON - DLON*KGDS(2)
ENDIF
DLON = -DLON
KGDS11 = KGDS11-128
ELSE
WLON = F0LON
ELON = F0LON + DLON*(KGDS(2)-1)
IF(DLON*KGDS(2).GT.359.99) THEN
ELON = F0LON + DLON*KGDS(2)
ENDIF
ENDIF
IF(KGDS11.GE.64) THEN
RNLAT = 99.
RSLAT = 99.
KGDS11 = KGDS11 - 64
ELSE
RNLAT = 99.
RSLAT = 99.
DLAT = -99.
ENDIF
IF(KGDS11.GE.32) THEN
IJORDR = .FALSE.
ELSE
IJORDR = .TRUE.
ENDIF
RETURN
!
ELSEIF(KGDS(1).EQ.5) THEN ! Polar Strereographic
WRITE(6,*) 'Polar Stereographic GRID'
WRITE(6,*) 'Cannot process'
CALL ABORT
RETURN
!
ELSEIF(KGDS(1).EQ.13) THEN ! Oblique Lambert conformal
WRITE(6,*) 'Oblique Lambert conformal GRID'
WRITE(6,*) 'Cannot process'
CALL ABORT
!
ELSEIF(KGDS(1).EQ.50) THEN ! Spherical Coefficient
WRITE(6,*) 'Spherical Coefficient'
WRITE(6,*) 'Cannot process'
CALL ABORT
RETURN
!
ELSEIF(KGDS(1).EQ.90) THEN ! Space view perspective
! (orthographic grid)
WRITE(6,*) 'Space view perspective GRID'
WRITE(6,*) 'Cannot process'
CALL ABORT
RETURN
!
ELSE ! Unknown projection. Abort.
WRITE(6,*) 'ERROR!! Unknown map projection'
WRITE(6,*) 'KGDS(1)=',KGDS(1)
PRINT *,'ERROR!! Unknown map projection'
PRINT *,'KGDS(1)=',KGDS(1)
CALL ABORT
ENDIF
!
RETURN
END
SUBROUTINE SUBST(DATA,IMAX,JMAX,DLON,DLAT,IJORDR)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,j,ii,jj,jmax,imax,iret
REAL (KIND=KIND_IO8) dlat,dlon
!
LOGICAL IJORDR
!
REAL (KIND=KIND_IO8) DATA(imax,jmax)
REAL (KIND=KIND_IO8), allocatable :: WORK(:,:)
!
IF(.NOT.IJORDR.OR.
& (IJORDR.AND.(DLAT.GT.0..OR.DLON.LT.0.))) THEN
allocate (WORK(imax,jmax))
IF(.NOT.IJORDR) THEN
DO J=1,JMAX
DO I=1,IMAX
work(i,j) = data(j,i)
ENDDO
ENDDO
ELSE
DO J=1,JMAX
DO I=1,IMAX
work(i,j) = data(i,j)
ENDDO
ENDDO
ENDIF
if (dlat > 0.0) then
if (dlon > 0.0) then
do j=1,jmax
jj = jmax - j + 1
do i=1,imax
data(i,jj) = work(i,j)
enddo
enddo
else
do i=1,imax
data(imax-i+1,jj) = work(i,j)
enddo
endif
else
if (dlon > 0.0) then
do j=1,jmax
do i=1,imax
data(i,j) = work(i,j)
enddo
enddo
else
do j=1,jmax
do i=1,imax
data(imax-i+1,j) = work(i,j)
enddo
enddo
endif
endif
deallocate (WORK, stat=iret)
ENDIF
RETURN
END
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,
& rnume,alamd,denom
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(:)
integer, allocatable :: ifill(:)
!
! INTERPOLATION FROM LAT/LON OR GAUSSIAN GRID TO OTHER LAT/LON GRID
!
REAL (KIND=KIND_IO8) OUTLON(LEN),OUTLAT(LEN),GAUOUT(LEN),
& SLMASK(LEN)
REAL (KIND=KIND_IO8) REGIN (IMXIN,JMXIN),RSLMSK(IMXIN,JMXIN)
!
REAL (KIND=KIND_IO8) RINLAT(JMXIN), RINLON(IMXIN)
INTEGER IINDX1(LEN), IINDX2(LEN)
INTEGER JINDX1(LEN), JINDX2(LEN)
REAL (KIND=KIND_IO8) DDX(LEN), DDY(LEN), WRK(LEN)
!
LOGICAL LMASK
!
logical first
integer NUM_THREADS
data first /.true./
save NUM_THREADS, first
!
integer LEN_THREAD_M, LEN_THREAD, I1_T, I2_T
integer NUM_PARTHDS
!
if (first) then
NUM_THREADS = NUM_PARTHDS()
first = .false.
if (.not. allocated(imxnx)) allocate (imxnx(NUM_THREADS))
endif
!
if (me == 0) print *,' NUM_THREADS =',NUM_THREADS,' me=',me
!
! if(me .eq. 0) then
! PRINT *,'RLON=',RLON,' me=',me
! PRINT *,'RLAT=',RLAT,' me=',me,' imxin=',imxin,' jmxin=',jmxin
! endif
!
! DO J=1,JMXIN
! IF(RLAT.GT.0.) THEN
! RINLAT(J) = RLAT - FLOAT(J-1)*DLAIN
! ELSE
! RINLAT(J) = RLAT + FLOAT(J-1)*DLAIN
! ENDIF
! ENDDO
!
! if (me .eq. 0) then
! PRINT *,'RINLAT='
! PRINT *,(RINLAT(J),J=1,JMXIN)
! PRINT *,'RINLON='
! PRINT *,(RINLON(I),I=1,IMXIN)
!
! PRINT *,'OUTLAT='
! PRINT *,(OUTLAT(J),J=1,LEN)
! PRINT *,(OUTLON(J),J=1,LEN)
! endif
!
! DO I=1,IMXIN
! RINLON(I) = RLON + FLOAT(I-1)*DLOIN
! ENDDO
!
! PRINT *,'RINLON='
! PRINT *,(RINLON(I),I=1,IMXIN)
!
LEN_THREAD_M = (LEN+NUM_THREADS-1) / NUM_THREADS
if (.not. allocated(ifill)) allocate (ifill(NUM_THREADS))
!
!$OMP PARALLEL DO PRIVATE(I1_T,I2_T,LEN_THREAD,IT,I,II,I1,I2)
!$OMP+PRIVATE(J,J1,J2,JQ,IX,JY,NX,KXS,KXT,KMAMI)
!$OMP+PRIVATE(ALAMD,DENOM,RNUME,APHI,X,Y,WSUM,WSUMIV,SUM1,SUM2)
!$OMP+PRIVATE(SUM3,SUM4,WI1J1,WI2J1,WI1J2,WI2J2,WEI1,WEI2,WEI3,WEI4)
!$OMP+PRIVATE(SUMN,SUMS)
!$OMP+SHARED(IMXIN,JMXIN,IFILL)
!$OMP+SHARED(OUTLON,OUTLAT,WRK,IINDX1,RINLON,JINDX1,RINLAT,DDX,DDY)
!$OMP+SHARED(RLON,RLAT,REGIN,GAUOUT,IMXNX)
!
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)
LEN_THREAD = I2_T-I1_T+1
!
! FIND I-INDEX FOR INTERPOLATION
!
DO I=I1_T, I2_T
ALAMD = OUTLON(I)
IF (ALAMD .LT. RLON) ALAMD = ALAMD + 360.0
IF (ALAMD .GT. 360.0+RLON) ALAMD = ALAMD - 360.0
WRK(I) = ALAMD
IINDX1(I) = IMXIN
ENDDO
DO I=I1_T,I2_T
DO II=1,IMXIN
IF(WRK(I) .GE. RINLON(II)) IINDX1(I) = II
ENDDO
ENDDO
DO I=I1_T,I2_T
I1 = IINDX1(I)
IF (I1 .LT. 1) I1 = IMXIN
I2 = I1 + 1
IF (I2 .GT. IMXIN) I2 = 1
IINDX1(I) = I1
IINDX2(I) = I2
DENOM = RINLON(I2) - RINLON(I1)
IF(DENOM.LT.0.) DENOM = DENOM + 360.
RNUME = WRK(I) - RINLON(I1)
IF(RNUME.LT.0.) RNUME = RNUME + 360.
DDX(I) = RNUME / DENOM
ENDDO
!
! FIND J-INDEX FOR INTERPLATION
!
IF(RLAT.GT.0.) THEN
DO J=I1_T,I2_T
JINDX1(J)=0
ENDDO
DO JX=1,JMXIN
DO J=I1_T,I2_T
IF(OUTLAT(J).LE.RINLAT(JX)) JINDX1(J) = JX
ENDDO
ENDDO
DO J=I1_T,I2_T
JQ = JINDX1(J)
APHI=OUTLAT(J)
IF(JQ.GE.1 .AND. JQ .LT. JMXIN) THEN
J2=JQ+1
J1=JQ
DDY(J)=(APHI-RINLAT(J1))/(RINLAT(J2)-RINLAT(J1))
ELSEIF (JQ .EQ. 0) THEN
J2=1
J1=1
IF(ABS(90.-RINLAT(J1)).GT.0.001) THEN
DDY(J)=(APHI-RINLAT(J1))/(90.-RINLAT(J1))
ELSE
DDY(J)=0.0
ENDIF
ELSE
J2=JMXIN
J1=JMXIN
IF(ABS(-90.-RINLAT(J1)).GT.0.001) THEN
DDY(J)=(APHI-RINLAT(J1))/(-90.-RINLAT(J1))
ELSE
DDY(J)=0.0
ENDIF
ENDIF
JINDX1(J)=J1
JINDX2(J)=J2
ENDDO
ELSE
DO J=I1_T,I2_T
JINDX1(J) = JMXIN+1
ENDDO
DO JX=JMXIN,1,-1
DO J=I1_T,I2_T
IF(OUTLAT(J).LE.RINLAT(JX)) JINDX1(J) = JX
ENDDO
ENDDO
DO J=I1_T,I2_T
JQ = JINDX1(J)
APHI=OUTLAT(J)
IF(JQ.GT.1 .AND. JQ .LE. JMXIN) THEN
J2=JQ
J1=JQ-1
DDY(J)=(APHI-RINLAT(J1))/(RINLAT(J2)-RINLAT(J1))
ELSEIF (JQ .EQ. 1) THEN
J2=1
J1=1
IF(ABS(-90.-RINLAT(J1)).GT.0.001) THEN
DDY(J)=(APHI-RINLAT(J1))/(-90.-RINLAT(J1))
ELSE
DDY(J)=0.0
ENDIF
ELSE
J2=JMXIN
J1=JMXIN
IF(ABS(90.-RINLAT(J1)).GT.0.001) THEN
DDY(J)=(APHI-RINLAT(J1))/(90.-RINLAT(J1))
ELSE
DDY(J)=0.0
ENDIF
ENDIF
JINDX1(J)=J1
JINDX2(J)=J2
ENDDO
ENDIF
!
! if (me .eq. 0 .and. inttyp .eq. 1) then
! PRINT *,'LA2GA'
! PRINT *,'IINDX1'
! PRINT *,(IINDX1(N),N=1,LEN)
! PRINT *,'IINDX2'
! PRINT *,(IINDX2(N),N=1,LEN)
! PRINT *,'JINDX1'
! PRINT *,(JINDX1(N),N=1,LEN)
! PRINT *,'JINDX2'
! PRINT *,(JINDX2(N),N=1,LEN)
! PRINT *,'DDY'
! PRINT *,(DDY(N),N=1,LEN)
! PRINT *,'DDX'
! PRINT *,(DDX(N),N=1,LEN)
! endif
!
SUM1 = 0.
SUM2 = 0.
SUM3 = 0.
SUM4 = 0.
IF (LMASK) THEN
WEI1 = 0.
WEI2 = 0.
WEI3 = 0.
WEI4 = 0.
DO I=1,IMXIN
SUM1 = SUM1 + REGIN(I,1) * RSLMSK(I,1)
SUM2 = SUM2 + REGIN(I,JMXIN) * RSLMSK(I,JMXIN)
WEI1 = WEI1 + RSLMSK(I,1)
WEI2 = WEI2 + RSLMSK(I,JMXIN)
!
SUM3 = SUM3 + REGIN(I,1) * (1.0-RSLMSK(I,1))
SUM4 = SUM4 + REGIN(I,JMXIN) * (1.0-RSLMSK(I,JMXIN))
WEI3 = WEI3 + (1.0-RSLMSK(I,1))
WEI4 = WEI4 + (1.0-RSLMSK(I,JMXIN))
ENDDO
!
IF(WEI1.GT.0.) THEN
SUM1 = SUM1 / WEI1
ELSE
SUM1 = 0.
ENDIF
IF(WEI2.GT.0.) THEN
SUM2 = SUM2 / WEI2
ELSE
SUM2 = 0.
ENDIF
IF(WEI3.GT.0.) THEN
SUM3 = SUM3 / WEI3
ELSE
SUM3 = 0.
ENDIF
IF(WEI4.GT.0.) THEN
SUM4 = SUM4 / WEI4
ELSE
SUM4 = 0.
ENDIF
ELSE
DO I=1,IMXIN
SUM1 = SUM1 + REGIN(I,1)
SUM2 = SUM2 + REGIN(I,JMXIN)
ENDDO
SUM1 = SUM1 / IMXIN
SUM2 = SUM2 / IMXIN
SUM3 = SUM1
SUM4 = SUM2
ENDIF
!
! print *,' SUM1=',SUM1,' SUM2=',SUM2
! *,' SUM3=',SUM3,' SUM4=',SUM4
! print *,' RSLMSK=',(RSLMSK(I,1),I=1,IMXIN)
! print *,' SLMASK=',(SLMASK(I),I=1,IMXOUT)
! *,' j1=',jindx1(1),' j2=',jindx2(1)
!
!
! INTTYP=1 Take the closest point value
!
IF(INTTYP.EQ.1) THEN
DO I=I1_T,I2_T
JY = JINDX1(I)
IF(DDY(I) .GE. 0.5) JY = JINDX2(I)
IX = IINDX1(I)
IF(DDX(I) .GE. 0.5) IX = IINDX2(I)
!
!cggg start
!
if (.not. lmask) then
GAUOUT(I) = REGIN(IX,JY)
else
IF(SLMASK(I).EQ.RSLMSK(IX,JY)) THEN
GAUOUT(I) = REGIN(IX,JY)
else
i1 = ix
j1 = jy
! SPIRAL AROUND UNTIL MATCHING MASK IS FOUND.
DO NX=1,JMXIN*IMXIN/2
KXS=SQRT(4*NX-2.5)
KXT=NX-INT(KXS**2/4+1)
SELECT CASE(MOD(KXS,4))
CASE(1)
IX=I1-KXS/4+KXT
JX=J1-KXS/4
CASE(2)
IX=I1+1+KXS/4
JX=J1-KXS/4+KXT
CASE(3)
IX=I1+1+KXS/4-KXT
JX=J1+1+KXS/4
CASE DEFAULT
IX=I1-KXS/4
JX=J1+KXS/4-KXT
END SELECT
IF(JX.LT.1) THEN
IX=IX+IMXIN/2
JX=2-JX
ELSEIF(JX.GT.JMXIN) THEN
IX=IX+IMXIN/2
JX=2*JMXIN-JX
ENDIF
IX=MODULO(IX-1,IMXIN)+1
IF(SLMASK(I).EQ.RSLMSK(IX,JX)) THEN
GAUOUT(I) = REGIN(IX,JX)
GO TO 81
ENDIF
ENDDO
!cggg here, set the gauout value to be 0, and let's sarah's land
!cggg routine assign a default.
if (NUM_THREADS == 1) then
print*,'no matching mask found ',i,i1,j1,ix,jx
print*,'set to default value.'
endif
gauout(i) = 0.0
81 continue
end if
end if
!cggg end
ENDDO
KMAMI=1
if (me == 0 .and. NUM_THREADS == 1)
& CALL MAXMIN(GAUOUT(I1_T),LEN_THREAD,KMAMI)
CYCLE
ENDIF ! nearest neighbor interpolation
!
! QUASI-BILINEAR INTERPOLATION
!
IFILL(it) = 0
IMXNX(it) = 0
DO I=I1_T,I2_T
Y = DDY(I)
J1 = JINDX1(I)
J2 = JINDX2(I)
X = DDX(I)
I1 = IINDX1(I)
I2 = IINDX2(I)
!
WI1J1 = (1.-X) * (1.-Y)
WI2J1 = X *( 1.-Y)
WI1J2 = (1.-X) * Y
WI2J2 = X * Y
!
TEM = 4.*SLMASK(I) - RSLMSK(I1,J1) - RSLMSK(I2,J1)
& - RSLMSK(I1,J2) - RSLMSK(I2,J2)
IF(LMASK .AND. ABS(TEM) .GT. 0.01) THEN
IF(SLMASK(I).EQ.1.) THEN
WI1J1 = WI1J1 * RSLMSK(I1,J1)
WI2J1 = WI2J1 * RSLMSK(I2,J1)
WI1J2 = WI1J2 * RSLMSK(I1,J2)
WI2J2 = WI2J2 * RSLMSK(I2,J2)
ELSE
WI1J1 = WI1J1 * (1.0-RSLMSK(I1,J1))
WI2J1 = WI2J1 * (1.0-RSLMSK(I2,J1))
WI1J2 = WI1J2 * (1.0-RSLMSK(I1,J2))
WI2J2 = WI2J2 * (1.0-RSLMSK(I2,J2))
ENDIF
ENDIF
!
WSUM = WI1J1 + WI2J1 + WI1J2 + WI2J2
WRK(I) = WSUM
IF(WSUM.NE.0.) THEN
WSUMIV = 1./WSUM
!
IF(J1.NE.J2) THEN
GAUOUT(I) = (WI1J1*REGIN(I1,J1) + WI2J1*REGIN(I2,J1) +
& WI1J2*REGIN(I1,J2) + WI2J2*REGIN(I2,J2))
& *WSUMIV
ELSE
!
IF (RLAT .GT. 0.0) THEN
IF (SLMASK(I) .EQ. 1.0) THEN
SUMN = SUM1
SUMS = SUM2
ELSE
SUMN = SUM3
SUMS = SUM4
ENDIF
IF( J1 .EQ. 1) THEN
GAUOUT(I) = (WI1J1*SUMN +WI2J1*SUMN +
& WI1J2*REGIN(I1,J2)+WI2J2*REGIN(I2,J2))
& * WSUMIV
ELSEIF (J1 .EQ. JMXIN) THEN
GAUOUT(I) = (WI1J1*REGIN(I1,J1)+WI2J1*REGIN(I2,J1)+
& WI1J2*SUMS +WI2J2*SUMS )
& * WSUMIV
ENDIF
! print *,' slmask=',slmask(i),' sums=',sums,' sumn=',sumn
! &,' regin=',regin(i1,j2),regin(i2,j2),' j1=',j1,' j2=',j2
! &,' wij=',wi1j1, wi2j1, wi1j2, wi2j2,wsumiv
ELSE
IF (SLMASK(I) .EQ. 1.0) THEN
SUMS = SUM1
SUMN = SUM2
ELSE
SUMS = SUM3
SUMN = SUM4
ENDIF
IF( J1 .EQ. 1) THEN
GAUOUT(I) = (WI1J1*REGIN(I1,J1)+WI2J1*REGIN(I2,J1)+
& WI1J2*SUMS +WI2J2*SUMS )
& * WSUMIV
ELSEIF (J1 .EQ. JMXIN) THEN
GAUOUT(I) = (WI1J1*SUMN +WI2J1*SUMN +
& WI1J2*REGIN(I1,J2)+WI2J2*REGIN(I2,J2))
& * WSUMIV
ENDIF
ENDIF
ENDIF ! if j1 .ne. j2
ENDIF
ENDDO
DO I=I1_T,I2_T
J1 = JINDX1(I)
J2 = JINDX2(I)
I1 = IINDX1(I)
I2 = IINDX2(I)
IF(WRK(I) .EQ. 0.0) THEN
IF(.NOT.LMASK) THEN
if (NUM_THREADS == 1)
& WRITE(6,*) ' LA2GA called with LMASK=.TRUE. but bad',
& ' RSLMSK or SLMASK given'
CALL ABORT
ENDIF
IFILL(it) = IFILL(it) + 1
IF(IFILL(it) <= 2 ) THEN
if (me == 0 .and. NUM_THREADS == 1) then
WRITE(6,*) 'I1,I2,J1,J2=',I1,I2,J1,J2
WRITE(6,*) 'RSLMSK=',RSLMSK(I1,J1),RSLMSK(I1,J2),
& RSLMSK(I2,J1),RSLMSK(I2,J2)
! WRITE(6,*) 'I,J=',I,J,' SLMASK(I)=',SLMASK(I)
WRITE(6,*) 'I=',I,' SLMASK(I)=',SLMASK(I)
&, ' outlon=',outlon(i),' outlat=',outlat(i)
endif
ENDIF
! SPIRAL AROUND UNTIL MATCHING MASK IS FOUND.
DO NX=1,JMXIN*IMXIN/2
KXS=SQRT(4*NX-2.5)
KXT=NX-INT(KXS**2/4+1)
SELECT CASE(MOD(KXS,4))
CASE(1)
IX=I1-KXS/4+KXT
JX=J1-KXS/4
CASE(2)
IX=I1+1+KXS/4
JX=J1-KXS/4+KXT
CASE(3)
IX=I1+1+KXS/4-KXT
JX=J1+1+KXS/4
CASE DEFAULT
IX=I1-KXS/4
JX=J1+KXS/4-KXT
END SELECT
IF(JX.LT.1) THEN
IX=IX+IMXIN/2
JX=2-JX
ELSEIF(JX.GT.JMXIN) THEN
IX=IX+IMXIN/2
JX=2*JMXIN-JX
ENDIF
IX=MODULO(IX-1,IMXIN)+1
IF(SLMASK(I).EQ.RSLMSK(IX,JX)) THEN
GAUOUT(I) = REGIN(IX,JX)
IMXNX(it) = MAX(IMXNX(it),NX)
GO TO 71
ENDIF
ENDDO
!
if (NUM_THREADS == 1) then
WRITE(6,*) ' ERROR!!! No filling value found in LA2GA'
! WRITE(6,*) ' I IX JX SLMASK(I) RSLMSK ',
! & I,IX,JX,SLMASK(I),RSLMSK(IX,JX)
endif
CALL ABORT
!
71 CONTINUE
ENDIF
!
ENDDO
ENDDO ! END OF THREADED LOOP ...................
!$OMP END PARALLEL DO
!
ifills = 0
do it=1,num_threads
ifills = ifills + ifill(it)
enddo
IF(IFILLS.GT.1) THEN
if (me .eq. 0) then
WRITE(6,*) ' Unable to interpolate. Filled with nearest',
& ' point value at ',IFILLS,' points'
! & ' point value at ',IFILLS,' points imxnx=',imxnx(:)
endif
ENDIF
deallocate (ifill)
!
KMAMI=1
if (me .eq. 0) CALL MAXMIN(GAUOUT,LEN,KMAMI)
!
RETURN
END SUBROUTINE LA2GA
SUBROUTINE MAXMIN(F,IMAX,KMAX)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,iimin,iimax,kmax,imax,k
REAL (KIND=KIND_IO8) fmin,fmax
!
REAL (KIND=KIND_IO8) F(IMAX,KMAX)
!
DO K=1,KMAX
!
FMAX = F(1,K)
FMIN = F(1,K)
!
DO I=1,IMAX
IF(FMAX.LE.F(I,K)) THEN
FMAX = F(I,K)
IIMAX = I
ENDIF
IF(FMIN.GE.F(I,K)) THEN
FMIN = F(I,K)
IIMIN = I
ENDIF
ENDDO
!
WRITE(6,100) K,FMAX,IIMAX,FMIN,IIMIN
100 FORMAT(2X,'LEVEL=',I2,' MAX=',E11.4,' AT I=',I7,
& ' MIN=',E11.4,' AT I=',I7)
!
ENDDO
!
RETURN
END
SUBROUTINE FILANL(TSFANL,TSFAN2,WETANL,SNOANL,ZORANL,ALBANL,
& AISANL,
& TG3ANL,CVANL ,CVBANL,CVTANL,
& CNPANL,SMCANL,STCANL,SLIANL,SCVANL,VEGANL,
& vetanl,sotanl,ALFANL,
!Cwu [+1L] add ()anl for sih, sic
& SIHANL,SICANL,
!Clu [+1L] add ()anl for vmn, vmx, slp, abs
& VMNANL,VMXANL,SLPANL,ABSANL,
& TSFCLM,TSFCL2,WETCLM,SNOCLM,ZORCLM,ALBCLM,
& AISCLM,
& TG3CLM,CVCLM ,CVBCLM,CVTCLM,
& CNPCLM,SMCCLM,STCCLM,SLICLM,SCVCLM,VEGCLM,
& vetclm,sotclm,ALFCLM,
!Cwu [+1L] add ()clm for sih, sic
& SIHCLM,SICCLM,
!Clu [+1L] add ()clm for vmn, vmx, slp, abs
& VMNCLM,VMXCLM,SLPCLM,ABSCLM,
& LEN,LSOIL)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,j,len,lsoil
!
REAL (KIND=KIND_IO8) TSFANL(LEN),TSFAN2(LEN),WETANL(LEN),
& SNOANL(LEN),
& ZORANL(LEN),ALBANL(LEN,4),AISANL(LEN),
& TG3ANL(LEN),
& CVANL (LEN),CVBANL(LEN),CVTANL(LEN),
& CNPANL(LEN),
& SMCANL(LEN,LSOIL),STCANL(LEN,LSOIL),
& SLIANL(LEN),SCVANL(LEN),VEGANL(LEN),
& vetanl(LEN),sotanl(LEN),ALFANL(LEN,2)
!Cwu [+1L] add ()anl for sih, sic
&, SIHANL(LEN),SICANL(LEN)
!Clu [+1L] add ()anl for vmn, vmx, slp, abs
&, 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
TSFANL(I) = TSFCLM(I) ! Tsf at t
TSFAN2(I) = TSFCL2(I) ! Tsf at t-deltsfc
WETANL(I) = WETCLM(I) ! Soil Wetness
SNOANL(I) = SNOCLM(I) ! SNOW
SCVANL(I) = SCVCLM(I) ! SNOW COVER
AISANL(I) = AISCLM(I) ! SEAICE
SLIANL(I) = SLICLM(I) ! LAND/SEA/SNOW mask
ZORANL(I) = ZORCLM(I) ! Surface roughness
! PLRANL(I) = PLRCLM(I) ! Maximum stomatal resistance
TG3ANL(I) = TG3CLM(I) ! Deep soil temperature
CNPANL(I) = CNPCLM(I) ! Canopy water content
VEGANL(I) = VEGCLM(I) ! Vegetation cover
VEtANL(I) = VEtCLM(I) ! Vegetation type
sotANL(I) = sotCLM(I) ! Soil type
CVANL(I) = CVCLM(I) ! CV
CVBANL(I) = CVBCLM(I) ! CVB
CVTANL(I) = CVTCLM(I) ! CVT
!Cwu [+4L] add sih, sic
SIHANL(I) = SIHCLM(I) ! Sea ice thickness
SICANL(I) = SICCLM(I) ! Sea ice concentration
!Clu [+4L] add vmn, vmx, slp, abs
VMNANL(I) = VMNCLM(I) ! Min vegetation cover
VMXANL(I) = VMXCLM(I) ! Max vegetation cover
SLPANL(I) = SLPCLM(I) ! slope type
ABSANL(I) = ABSCLM(I) ! Max snow albedo
ENDDO
!
DO J=1,LSOIL
DO I=1,LEN
SMCANL(I,J) = SMCCLM(I,J) ! Layer soil wetness
STCANL(I,J) = STCCLM(I,J) ! Soil temperature
ENDDO
ENDDO
DO J=1,4
DO I=1,LEN
ALBANL(I,J) = ALBCLM(I,J) ! Albedo
ENDDO
ENDDO
DO J=1,2
DO I=1,LEN
ALFANL(I,J) = ALFCLM(I,J) ! Vegetation fraction for Albedo
ENDDO
ENDDO
!
RETURN
END
SUBROUTINE ANALY(LUGB,IY,IM,ID,IH,FH,LEN,LSOIL,
& SLMASK,FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
& FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,FNVEGA,
& fnveta,fnsota,
!Clu [+1L] add fn()a for vmn, vmx, slp, abs
& FNVMNA,FNVMXA,FNSLPA,FNABSA,
& TSFANL,WETANL,SNOANL,ZORANL,ALBANL,AISANL,
& TG3ANL,CVANL ,CVBANL,CVTANL,
& SMCANL,STCANL,SLIANL,SCVANL,ACNANL,VEGANL,
& vetanl,sotanl,ALFANL,TSFAN0,
!Clu [+1L] add ()anl for vmn, vmx, slp, abs
& VMNANL,VMXANL,SLPANL,ABSANL,
!cggg snow mods start & KPDTSF,KPDWET,KPDSNO,KPDZOR,KPDALB,KPDAIS,
& KPDTSF,KPDWET,KPDSNO,KPDSND,KPDZOR,KPDALB,KPDAIS,
!cggg snow mods end
& KPDTG3,KPDSCV,KPDACN,KPDSMC,KPDSTC,KPDVEG,
& kprvet,kpdsot,kpdalf,
!Clu [+1L] add kpd() for vmn, vmx, slp, abs
& KPDVMN,KPDVMX,KPDSLP,KPDABS,
& IRTTSF,IRTWET,IRTSNO,IRTZOR,IRTALB,IRTAIS,
& IRTTG3,IRTSCV,IRTACN,IRTSMC,IRTSTC,IRTVEG,
& irtvet,irtsot,irtalf
!Clu [+1L] add irt() for vmn, vmx, slp, abs
&, IRTVMN,IRTVMX,IRTSLP,IRTABS
&, IMSK, JMSK, SLMSKH, OUTLAT, OUTLON
&, GAUS, BLNO, BLTO, me)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
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
!
REAL (KIND=KIND_IO8) SLMASK(LEN)
REAL (KIND=KIND_IO8) SLMSKH(IMSK,JMSK)
REAL (KIND=KIND_IO8) OUTLAT(LEN), OUTLON(LEN)
INTEGER kpdalb(4), kpdalf(2)
!cggg snow mods start
INTEGER KPDS(1000),KGDS(1000),JPDS(1000),JGDS(1000)
INTEGER LUGI, LSKIP, LGRIB, NDATA
!cggg snow mods end
!
CHARACTER*500 FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
& FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,FNVEGA,
& fnveta,fnsota
!Clu [+1L] add fn()a for vmn, vmx, slp, abs
&, FNVMNA,FNVMXA,FNSLPA,FNABSA
REAL (KIND=KIND_IO8) TSFANL(LEN), WETANL(LEN), SNOANL(LEN),
& ZORANL(LEN), ALBANL(LEN,4), AISANL(LEN),
& TG3ANL(LEN), ACNANL(LEN),
& CVANL (LEN), CVBANL(LEN), CVTANL(LEN),
& SLIANL(LEN), SCVANL(LEN), VEGANL(LEN),
& vetanl(LEN), sotanl(LEn), ALFANL(LEN,2),
& SMCANL(LEN,LSOIL), STCANL(LEN,LSOIL),
& TSFAN0(LEN)
!Clu [+1L] add ()anl for vmn, vmx, slp, abs
&, VMNANL(LEN),VMXANL(LEN),SLPANL(LEN),ABSANL(LEN)
!
LOGICAL GAUS
!
! TSF
!
IRTTSF=0
IF(FNTSFA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNTSFA,KPDTSF,SLMASK,
& IY,IM,ID,IH,FH,TSFANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTTSF=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'T SURFACE ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD T SURFACE ANALYSIS PROVIDED, Indicating proper',
& ' file name is given. No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'T SURFACE ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO TSF ANALYSIS AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! TSF0
!
! IF(FNTSFA(1:8).NE.' ') THEN
! CALL FIXRDA(LUGB,FNTSFA,KPDTSF,SLMASK,
! & IY,IM,ID,IH,0.,TSFAN0,LEN,IRET
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
! IF(IRET.EQ.1) THEN
! WRITE(6,*) 'T SURFACE AT FT=0 ANALYSIS READ ERROR'
! CALL ABORT
! ELSEIF(IRET.EQ.-1) THEN
! WRITE(6,*) 'COULD NOT FIND T SURFACE ANALYSIS AT FT=0'
! CALL ABORT
! ELSE
! PRINT *,'T SURFACE ANALYSIS AT FT=0 FOUND.'
! ENDIF
! ELSE
! DO I=1,LEN
! TSFAN0(I)=-999.9
! ENDDO
! ENDIF
!
! ALBEDO
!
IRTALB=0
IF(FNALBA(1:8).NE.' ') THEN
DO KK = 1, 4
CALL FIXRDA(LUGB,FNALBA,KPDALB(KK),SLMASK,
& IY,IM,ID,IH,FH,ALBANL(1,KK),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTALB=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'ALBEDO ANALYSIS READ ERROR'
CALL ABORT
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 .eq. 0 .and. kk .eq. 4)
& PRINT *,'ALBEDO ANALYSIS PROVIDED.'
ENDIF
ENDDO
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO ALBEDO ANALYSIS AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! Vegetation Fraction for albedo
!
IRTALF=0
IF(FNALBA(1:8).NE.' ') THEN
DO KK = 1, 2
CALL FIXRDA(LUGB,FNALBA,KPDALF(KK),SLMASK,
& IY,IM,ID,IH,FH,ALFANL(1,KK),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTALF=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'ALBEDO ANALYSIS READ ERROR'
CALL ABORT
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 .eq. 0 .and. kk .eq. 4)
& PRINT *,'ALBEDO ANALYSIS PROVIDED.'
ENDIF
ENDDO
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO VEGFALBEDO ANALYSIS AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! Soil Wetness
!
IRTWET=0
IRTSMC=0
IF(FNWETA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNWETA,KPDWET,SLMASK,
& IY,IM,ID,IH,FH,WETANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTWET=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'BUCKET WETNESS ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD WETNESS ANALYSIS PROVIDED, Indicating proper',
& ' file name is given. No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'BUCKET WETNESS ANALYSIS PROVIDED.'
ENDIF
ELSEIF(FNSMCA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNSMCA,KPDSMC,SLMASK,
& IY,IM,ID,IH,FH,SMCANL(1,1),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
CALL FIXRDA(LUGB,FNSMCA,KPDSMC,SLMASK,
& IY,IM,ID,IH,FH,SMCANL(1,2),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTSMC=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'LAYER SOIL WETNESS ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD LAYER SOIL WETNESS ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'LAYER SOIL WETNESS ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO SOIL WETNESS ANALYSIS AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! READ IN SNOW DEPTH/SNOW COVER
!
IRTSCV=0
IF(FNSNOA(1:8).NE.' ') THEN
DO I=1,LEN
SCVANL(I)=0.
ENDDO
!cggg snow mods start
!cggg need to determine if the snow data is on the gaussian grid
!cggg or not. if gaussian, then data is a depth, not liq equiv
!cggg depth. if not gaussian, then data is from hua-lu's
!cggg program and is a liquid equiv. need to communicate
!cggg this to routine fixrda via the 3rd argument which is
!cggg the grib parameter id number.
CALL BAOPENR(LUGB,FNSNOA,IRET)
IF (IRET .NE. 0) THEN
WRITE(6,*) ' ERROR IN OPENING FILE ',trim(FNSNOA)
PRINT *,'ERROR IN OPENING FILE ',trim(FNSNOA)
CALL ABORT
ENDIF
LUGI=0
lskip=-1
JPDS=-1
JGDS=-1
KPDS=JPDS
CALL GETGBH(LUGB,LUGI,LSKIP,JPDS,JGDS,LGRIB,NDATA,
& LSKIP,KPDS,KGDS,IRET)
CLOSE(LUGB)
IF (IRET .NE. 0) THEN
WRITE(6,*) ' ERROR READING HEADER OF FILE: ',trim(FNSNOA)
PRINT *,'ERROR READING HEADER OF FILE: ',trim(FNSNOA)
CALL ABORT
ENDIF
IF (KGDS(1) == 4) THEN ! GAUSSIAN DATA IS DEPTH
CALL FIXRDA(LUGB,FNSNOA,KPDSND,SLMASK,
& IY,IM,ID,IH,FH,SNOANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
SNOANL=SNOANL*100. ! CONVERT FROM METERS TO LIQ. EQ.
! DEPTH IN MM USING 10:1 RATIO
ELSE ! LAT/LON DATA IS LIQ EQUV. DEPTH
CALL FIXRDA(LUGB,FNSNOA,KPDSNO,SLMASK,
& IY,IM,ID,IH,FH,SNOANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ENDIF
!cggg snow mods end
IRTSCV=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'SNOW DEPTH ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD SNOW DEPTH ANALYSIS PROVIDED, Indicating proper',
& ' file name is given. No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'SNOW DEPTH ANALYSIS PROVIDED.'
ENDIF
IRTSNO=0
ELSEIF(FNSCVA(1:8).NE.' ') THEN
DO I=1,LEN
SNOANL(I)=0.
ENDDO
CALL FIXRDA(LUGB,FNSCVA,KPDSCV,SLMASK,
& IY,IM,ID,IH,FH,SCVANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTSNO=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'SNOW COVER ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD SNOW COVER ANALYSIS PROVIDED, Indicating proper',
& ' file name is given. No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'SNOW COVER ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO SNOW/SNOCOV ANALYSIS AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! Sea ice mask
!
IRTACN=0
IRTAIS=0
IF(FNACNA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNACNA,KPDACN,SLMASK,
& IY,IM,ID,IH,FH,ACNANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTACN=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'ICE CONCENTRATION ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD ICE CONCENTRATION ANALYSIS PROVIDED',
& ' Indicating proper file name is given'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'ICE CONCENTRATION ANALYSIS PROVIDED.'
ENDIF
ELSEIF(FNAISA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNAISA,KPDAIS,SLMASK,
& IY,IM,ID,IH,FH,AISANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTAIS=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'ICE MASK ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD ICE-MASK ANALYSIS PROVIDED, Indicating proper',
& ' file name is given. No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'ICE MASK ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO SEA-ICE ANALYSIS AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! Surface Roughness
!
IRTZOR=0
IF(FNZORA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNZORA,KPDZOR,SLMASK,
& IY,IM,ID,IH,FH,ZORANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTZOR=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'ROUGHNESS ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD ROUGHNESS ANALYSIS PROVIDED, Indicating proper',
& ' file name is given. No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'ROUGHNESS ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO SRFC ROUGHNESS ANALYSIS AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! Deep Soil Temperature
!
IRTTG3=0
IRTSTC=0
IF(FNTG3A(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNTG3A,KPDTG3,SLMASK,
& IY,IM,ID,IH,FH,TG3ANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTTG3=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'DEEP SOIL TMP ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD DEEP SOIL TEMP ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'DEEP SOIL TMP ANALYSIS PROVIDED.'
ENDIF
ELSEIF(FNSTCA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNSTCA,KPDSTC,SLMASK,
& IY,IM,ID,IH,FH,STCANL(1,1),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
CALL FIXRDA(LUGB,FNSTCA,KPDSTC,SLMASK,
& IY,IM,ID,IH,FH,STCANL(1,2),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTSTC=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'LAYER SOIL TMP ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD DEEP SOIL TEMP ANALYSIS PROVIDED',
& 'iIndicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'LAYER SOIL TMP ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO DEEP SOIL TEMP ANALY AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! VEGETATION COVER
!
IRTVEG=0
IF(FNVEGA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNVEGA,KPDVEG,SLMASK,
& IY,IM,ID,IH,FH,VEGANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTVEG=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'VEGETATION COVER ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD VEGETATION COVER ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'GEGETATION COVER ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO VEGETATION COVER ANLY AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! VEGETATION type
!
IRTVEt=0
IF(FNVEtA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNVEtA,KPDVEt,SLMASK,
& IY,IM,ID,IH,FH,VEtANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTVEt=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'VEGETATION type ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD VEGETATION type ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'VEGETATION type ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO VEGETATION type ANLY AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! soil type
!
IRTsot=0
IF(FNsotA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNsotA,KPDsot,SLMASK,
& IY,IM,ID,IH,FH,sotANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTsot=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'soil type ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD soil type ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'soil type ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO soil type ANLY AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!Clu [+120L]--------------------------------------------------------------
!
! Min vegetation cover
!
IRTvmn=0
IF(FNvmnA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNvmnA,KPDvmn,SLMASK,
& IY,IM,ID,IH,FH,vmnANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTvmn=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'shdmin ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD shdmin ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'shdmin ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO shdmin ANLY AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! Max vegetation cover
!
IRTvmx=0
IF(FNvmxA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNvmxA,KPDvmx,SLMASK,
& IY,IM,ID,IH,FH,vmxANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTvmx=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'shdmax ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD shdmax ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'shdmax ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO shdmax ANLY AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! slope type
!
IRTslp=0
IF(FNslpA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNslpA,KPDslp,SLMASK,
& IY,IM,ID,IH,FH,slpANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTslp=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'slope type ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD slope type ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'slope type ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO slope type ANLY AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!
! Max snow albedo
!
IRTabs=0
IF(FNabsA(1:8).NE.' ') THEN
CALL FIXRDA(LUGB,FNabsA,KPDabs,SLMASK,
& IY,IM,ID,IH,FH,absANL,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
IRTabs=IRET
IF(IRET.EQ.1) THEN
WRITE(6,*) 'snoalb ANALYSIS READ ERROR'
CALL ABORT
ELSEIF(IRET.EQ.-1) THEN
if (me .eq. 0) then
PRINT *,'OLD snoalb ANALYSIS PROVIDED',
& ' Indicating proper file name is given.'
PRINT *,' No error suspected.'
WRITE(6,*) 'FORECAST GUESS WILL BE USED'
endif
ELSE
if (me .eq. 0) PRINT *,'snoalb ANALYSIS PROVIDED.'
ENDIF
ELSE
if (me .eq. 0) then
! PRINT *,'************************************************'
PRINT *,'NO snoalb ANLY AVAILABLE. CLIMATOLOGY USED'
endif
ENDIF
!Clu ----------------------------------------------------------------------
!
RETURN
END
SUBROUTINE FILFCS(TSFFCS,WETFCS,SNOFCS,ZORFCS,ALBFCS,
& TG3FCS,CVFCS ,CVBFCS,CVTFCS,
& CNPFCS,SMCFCS,STCFCS,SLIFCS,AISFCS,
& VEGFCS, vetfcs, sotfcs, alffcs,
!Cwu [+1L] add ()fcs for sih, sic
& SIHFCS,SICFCS,
!Clu [+1L] add ()fcs for vmn, vmx, slp, abs
& VMNFCS,VMXFCS,SLPFCS,ABSFCS,
& TSFANL,WETANL,SNOANL,ZORANL,ALBANL,
& TG3ANL,CVANL ,CVBANL,CVTANL,
& CNPANL,SMCANL,STCANL,SLIANL,AISANL,
& VEGANL, vetanl, sotanl, ALFANL,
!Cwu [+1L] add ()anl for sih, sic
& SIHANL,SICANL,
!Clu [+1L] add ()anl for vmn, vmx, slp, abs
& VMNANL,VMXANL,SLPANL,ABSANL,
& LEN,LSOIL)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,j,len,lsoil
REAL (KIND=KIND_IO8) TSFFCS(LEN),WETFCS(LEN),SNOFCS(LEN),
& ZORFCS(LEN),ALBFCS(LEN,4),AISFCS(LEN),
& TG3FCS(LEN),
& CVFCS (LEN),CVBFCS(LEN),CVTFCS(LEN),
& CNPFCS(LEN),
& SMCFCS(LEN,LSOIL),STCFCS(LEN,LSOIL),
& SLIFCS(LEN),VEGFCS(LEn),
& vetfcs(LEN),sotfcs(LEN),alffcs(LEN,2)
!Cwu [+1L] add ()fcs for sih, sic
&, SIHFCS(LEN),SICFCS(LEN)
!Clu [+1L] add ()fcs for vmn, vmx, slp, abs
&, 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',
& ' SET AS LOWEST SIGMA LEVEL TEMPERTURE IF GIVEN.'
WRITE(6,*) ' IF NOT, SET TO CLIMATOLOGICAL TSF OVER LAND IS USED'
!
!
DO I=1,LEN
TSFFCS(I) = TSFANL(I) ! Tsf
ALBFCS(I,1) = ALBANL(I,1) ! Albedo
ALBFCS(I,2) = ALBANL(I,2) ! Albedo
ALBFCS(I,3) = ALBANL(I,3) ! Albedo
ALBFCS(I,4) = ALBANL(I,4) ! Albedo
WETFCS(I) = WETANL(I) ! Soil Wetness
SNOFCS(I) = SNOANL(I) ! SNOW
AISFCS(I) = AISANL(I) ! SEAICE
SLIFCS(I) = SLIANL(I) ! LAND/SEA/SNOW mask
ZORFCS(I) = ZORANL(I) ! Surface roughness
! PLRFCS(I) = PLRANL(I) ! Maximum stomatal resistance
TG3FCS(I) = TG3ANL(I) ! Deep soil temperature
CNPFCS(I) = CNPANL(I) ! Canopy water content
CVFCS(I) = CVANL(I) ! CV
CVBFCS(I) = CVBANL(I) ! CVB
CVTFCS(I) = CVTANL(I) ! CVT
VEGFCS(I) = VEGANL(I) ! Vegetation Cover
vetfcs(I) = vetanl(I) ! Vegetation Type
sotfcs(I) = sotanl(I) ! Soil type
alffcs(I,1) = ALFANL(I,1) ! Vegetation fraction for albedo
alffcs(I,2) = ALFANL(I,2) ! Vegetation fraction for albedo
!Cwu [+2L] add sih, sic
SIHFCS(I) = SIHANL(I) ! Sea ice thickness
SICFCS(I) = SICANL(I) ! Sea ice concentration
!Clu [+4L] add vmn, vmx, slp, abs
VMNFCS(I) = VMNANL(I) ! Min vegetation Cover
VMXFCS(I) = VMXANL(I) ! Max vegetation Cover
SLPFCS(I) = SLPANL(I) ! Slope type
ABSFCS(I) = ABSANL(I) ! Max snow albedo
ENDDO
!
DO J=1,LSOIL
DO I=1,LEN
SMCFCS(I,J) = SMCANL(I,J) ! Layer soil wetness
STCFCS(I,J) = STCANL(I,J) ! Soil temperature
ENDDO
ENDDO
!
RETURN
END
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),
& SLIANL(LEN)
!
! Note that SMFCS comes in with the original unit (cm?) (not GRIB file)
!
DO I = 1, LEN
SMCFCS(I,1) = (SMCFCS(I,1)/150.) * .37 + .1
ENDDO
DO K = 2, LSOIL
DO I = 1, LEN
SMCFCS(I,K) = SMCFCS(I,1)
ENDDO
ENDDO
IF(LSOIL.GT.2) THEN
DO K = 3, LSOIL
DO I = 1, LEN
STCFCS(I,K) = STCFCS(I,2)
ENDDO
ENDDO
ENDIF
!
RETURN
END
SUBROUTINE ROF01(AISFLD,LEN,OP,CRIT)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,len
REAL (KIND=KIND_IO8) AISFLD(LEN),crit
CHARACTER*2 OP
!
IF(OP.EQ.'GE') THEN
DO I=1,LEN
IF(AISFLD(I).GE.CRIT) THEN
AISFLD(I)=1.
ELSE
AISFLD(I)=0.
ENDIF
ENDDO
ELSEIF(OP.EQ.'GT') THEN
DO I=1,LEN
IF(AISFLD(I).GT.CRIT) THEN
AISFLD(I)=1.
ELSE
AISFLD(I)=0.
ENDIF
ENDDO
ELSEIF(OP.EQ.'LE') THEN
DO I=1,LEN
IF(AISFLD(I).LE.CRIT) THEN
AISFLD(I)=1.
ELSE
AISFLD(I)=0.
ENDIF
ENDDO
ELSEIF(OP.EQ.'LT') THEN
DO I=1,LEN
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 TSFCOR(TSFC,OROG,SLMASK,UMASK,LEN,RLAPSE)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,len
REAL (KIND=KIND_IO8) rlapse,umask
REAL (KIND=KIND_IO8) TSFC(LEN), OROG(LEN), SLMASK(LEN)
!
DO I=1,LEN
IF(SLMASK(I).EQ.UMASK) THEN
TSFC(I) = TSFC(I) - OROG(I)*RLAPSE
ENDIF
ENDDO
RETURN
END
!cggg landice mods start
! SUBROUTINE SNODPTH(SCVANL,SLIANL,TSFANL,SNOCLM,
! & GLACIR,SNWMAX,SNWMIN,LEN,SNOANL, me)
SUBROUTINE SNODPTH(SCVANL,SLIANL,TSFANL,SNOCLM,
& GLACIR,SNWMAX,SNWMIN,LANDICE,LEN,SNOANL, me)
!cggg landice mods end
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,me,len
!cggg landice mods start
LOGICAL, INTENT(IN) :: LANDICE
!cggg landice mods end
REAL (KIND=KIND_IO8) sno,snwmax,snwmin
!
REAL (KIND=KIND_IO8) SCVANL(LEN), SLIANL(LEN), TSFANL(LEN),
& SNOCLM(LEN), SNOANL(LEN), GLACIR(LEN)
!
if (me .eq. 0) WRITE(6,*) 'SNODPTH'
!
! USE SURFACE TEMPERATURE TO GET SNOW DEPTH ESTIMATE
!
DO I=1,LEN
SNO = 0.0
!
! OVER LAND
!
IF(SLIANL(I).EQ.1.) THEN
IF(SCVANL(I).EQ.1.0) THEN
IF(TSFANL(I).LT.243.0) THEN
SNO = SNWMAX
ELSEIF(TSFANL(I).LT.273.0) THEN
SNO = SNWMIN+(SNWMAX-SNWMIN)*(273.0-TSFANL(I))/30.0
ELSE
SNO = SNWMIN
ENDIF
ENDIF
!
! IF GLACIAL POINTS HAS SNOW IN CLIMATOLOGY, SET SNO TO SNOMAX
!
!cggg landice mods start
IF (.NOT.LANDICE) THEN
!cggg landice mods end
IF(GLACIR(I).EQ.1.0) THEN
SNO = SNOCLM(I)
IF(SNO.EQ.0.) SNO=SNWMAX
ENDIF
!cggg landice mods start
ENDIF
!cggg landice mods end
ENDIF
!
! OVER SEA ICE
!
! Snow over sea ice is cycled as of 01/01/94.....Hua-Lu Pan
!
IF(SLIANL(I).EQ.2.0) THEN
SNO=SNOCLM(I)
IF(SNO.EQ.0.) SNO=SNWMAX
ENDIF
!
SNOANL(I) = SNO
ENDDO
RETURN
END
SUBROUTINE MERGE(LEN,LSOIL,IY,IM,ID,IH,FH,
!Cwu [+1L] add SIHFCS & SICFCS
& SIHFCS,SICFCS,
!Clu [+1L] add ()fcs for vmn, vmx, slp, abs
& VMNFCS,VMXFCS,SLPFCS,ABSFCS,
& TSFFCS,WETFCS,SNOFCS,ZORFCS,ALBFCS,AISFCS,
& CVFCS ,CVBFCS,CVTFCS,
& CNPFCS,SMCFCS,STCFCS,SLIFCS,VEGFCS,
& vetfcs,sotfcs,alffcs,
!Cwu [+1L] add SIHANL & SICANL
& SIHANL,SICANL,
!Clu [+1L] add ()anl for vmn, vmx, slp, abs
& 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,
!Cwu [+1L] add c()l and c()s for sih, sic
& CSIHL,CSIHS,CSICL,CSICS,
!Clu [+1L] add c()l and c()s for vmn, vmx, slp, abs
& CVMNL,CVMNS,CVMXL,CVMXS,CSLPL,CSLPS,CABSL,CABSS,
& IRTTSF,IRTWET,IRTSNO,IRTZOR,IRTALB,IRTAIS,
& IRTTG3,IRTSCV,IRTACN,IRTSMC,IRTSTC,IRTVEG,
!Clu [+1L] add irt() for vmn, vmx, slp, abs
& IRTVMN,IRTVMX,IRTSLP,IRTABS,
!cggg landice start
!cggg & irtvet,irtsot,irtalf, me)
& irtvet,irtsot,irtalf, landice, me)
!cggg landice end
USE MACHINE , ONLY : kind_io8,kind_io4
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
!Clu [+1L] add irt() for vmn, vmx, slp, abs
&, irtvmn,irtvmx,irtslp,irtabs
!cggg landice start
logical, intent(in) :: landice
!cggg landice end
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
!Cwu [+3L] add c(), q(), r() for sih, sic
&, csihl,csihs,csicl,csics,
& rsihl,rsihs,rsicl,rsics,
& qsihl,qsihs,qsicl,qsics
!Clu [+4L] add c(), q(), r() for vmn, vmx, slp, abs
&, 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)
!Cwu [+1L] add SIHFCS & SICFCS
&, 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),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)
!Cwu [+1L] add SIHANL & SICANL
&, SIHANL(LEN),SICANL(LEN)
!Clu [+1L] add ()anl for vmn, vmx, slp, abs
&, VMNANL(LEN),VMXANL(LEN),SLPANL(LEN),ABSANL(LEN)
! &, TSFAN2(LEN)
!
REAL (KIND=KIND_IO8) CSMCL(LSOIL), CSMCS(LSOIL),
& CSTCL(LSOIL), CSTCS(LSOIL)
REAL (KIND=KIND_IO8) RSMCL(LSOIL), RSMCS(LSOIL),
& RSTCL(LSOIL), RSTCS(LSOIL)
REAL (KIND=KIND_IO8) QSMCL(LSOIL), QSMCS(LSOIL),
& QSTCL(LSOIL), QSTCS(LSOIL)
logical first
integer NUM_THREADS
data first /.true./
save NUM_THREADS, first
!
integer LEN_THREAD_M, I1_T, I2_T, IT
integer NUM_PARTHDS
!
if (first) then
NUM_THREADS = NUM_PARTHDS()
first = .false.
endif
!
! COEEFICIENTS OF BLENDING FORECAST AND INTERPOLATED CLIM
! (OR ANALYZED) FIELDS OVER SEA OR LAND(L) (NOT FOR CLOUDS)
! 1.0 = USE OF FORECAST
! 0.0 = REPLACE WITH INTERPOLATED ANALYSIS
!
! Merging coefficients are defined by PARAMETER statement in calling program
! and therefore they should not be modified in this program.
!
!
RTSFL = CTSFL
RALBL = CALBL
RALFL = CALFL
RAISL = CAISL
RSNOL = CSNOL
!Clu RSMCL = CSMCL
RZORL = CZORL
RVEGL = CVEGL
rvetl = cvetl
rsotl = csotl
!Cwu [+2L] add sih, sic
RsihL = CsihL
RsicL = CsicL
!Clu [+4L] add vmn, vmx, slp, abs
RvmnL = CvmnL
RvmxL = CvmxL
RslpL = CslpL
RabsL = CabsL
!
RTSFS = CTSFS
RALBS = CALBS
RALFS = CALFS
RAISS = CAISS
RSNOS = CSNOS
! RSMCS = CSMCS
RZORS = CZORS
RVEGS = CVEGS
rvets = cvets
rsots = csots
!Cwu [+2L] add sih, sic
RsihS = CsihS
RsicS = CsicS
!Clu [+4L] add vmn, vmx, slp, abs
RvmnS = CvmnS
RvmxS = CvmxS
RslpS = CslpS
RabsS = CabsS
!
RCV = CCV
RCVB = CCVB
RCVT = CCVT
RCNP = CCNP
!
DO K=1,LSOIL
RSMCL(K) = CSMCL(K)
RSMCS(K) = CSMCS(K)
RSTCL(K) = CSTCL(K)
RSTCS(K) = CSTCS(K)
ENDDO
!
! If analysis file name is given but no matching analysis date found,
! use guess (these are flagged by IRT???=1).
!
IF(IRTTSF.EQ.-1) THEN
RTSFL = 1.
RTSFS = 1.
ENDIF
IF(IRTALB.EQ.-1) THEN
RALBL = 1.
RALBS = 1.
ralfl = 1.
ralfs = 1.
ENDIF
IF(IRTAIS.EQ.-1) THEN
RAISL = 1.
RAISS = 1.
ENDIF
IF(IRTSNO.EQ.-1.OR.IRTSCV.EQ.-1) THEN
RSNOL = 1.
RSNOS = 1.
ENDIF
IF(IRTSMC.EQ.-1.OR.IRTWET.EQ.-1) THEN
! RSMCL = 1.
! RSMCS = 1.
DO K=1,LSOIL
RSMCL(K) = 1.
RSMCS(K) = 1.
ENDDO
ENDIF
IF(IRTSTC.EQ.-1) THEN
DO K=1,LSOIL
RSTCL(K) = 1.
RSTCS(K) = 1.
ENDDO
ENDIF
IF(IRTZOR.EQ.-1) THEN
RZORL = 1.
RZORS = 1.
ENDIF
IF(IRTVEG.EQ.-1) THEN
RVEGL = 1.
RVEGS = 1.
ENDIF
IF(IRTvet.EQ.-1) THEN
RvetL = 1.
RvetS = 1.
ENDIF
IF(IRTsot.EQ.-1) THEN
RsotL = 1.
RsotS = 1.
ENDIF
!Cwu [+4L] -----------------------------------------------------------------
IF(IRTacn.EQ.-1) THEN
RsicL = 1.
RsicS = 1.
ENDIF
!Clu [+16L] -----------------------------------------------------------------
IF(IRTvmn.EQ.-1) THEN
RvmnL = 1.
RvmnS = 1.
ENDIF
IF(IRTvmx.EQ.-1) THEN
RvmxL = 1.
RvmxS = 1.
ENDIF
IF(IRTslp.EQ.-1) THEN
RslpL = 1.
RslpS = 1.
ENDIF
IF(IRTabs.EQ.-1) THEN
RabsL = 1.
RabsS = 1.
ENDIF
!Clu --------------------------------------------------------------------------
!
if(raiss.eq.1..or.irtacn.eq.-1) then
if (me .eq. 0) print *,'use forecast land-sea-ice mask'
do i = 1, LEN
aisanl(i) = aisfcs(i)
slianl(i) = slifcs(i)
enddo
endif
!
if (me .eq. 0) then
WRITE(6,100) RTSFL,RALBL,RAISL,RSNOL,RSMCL,RZORL,RVEGL
100 FORMAT('RTSFL,RALBL,RAISL,RSNOL,RSMCL,RZORL,RVEGL=',10F7.3)
WRITE(6,101) RTSFS,RALBS,RAISS,RSNOS,RSMCS,RZORS,RVEGS
101 FORMAT('RTSFS,RALBS,RAISS,RSNOS,RSMCS,RZORS,RVEGS=',10F7.3)
! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl
! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets
endif
!
QTSFL = 1. - RTSFL
QALBL = 1. - RALBL
QALFL = 1. - RALFL
QAISL = 1. - RAISL
QSNOL = 1. - RSNOL
! QSMCL = 1. - RSMCL
QZORL = 1. - RZORL
QVEGL = 1. - RVEGL
QVETL = 1. - RVETL
QsoTL = 1. - RsoTL
!Cwu [+2L] add sih, sic
QsihL = 1. - RsihL
QsicL = 1. - RsicL
!Clu [+4L] add vmn, vmx, slp, abs
QvmnL = 1. - RvmnL
QvmxL = 1. - RvmxL
QslpL = 1. - RslpL
QabsL = 1. - RabsL
!
QTSFS = 1. - RTSFS
QALBS = 1. - RALBS
QALFS = 1. - RALFS
QAISS = 1. - RAISS
QSNOS = 1. - RSNOS
! QSMCS = 1. - RSMCS
QZORS = 1. - RZORS
QVEGS = 1. - RVEGS
QVEtS = 1. - RVEtS
QsotS = 1. - RsotS
!Cwu [+2L] add sih, sic
QsihS = 1. - RsihS
QsicS = 1. - RsicS
!Clu [+4L] add vmn, vmx, slp, abs
QvmnS = 1. - RvmnS
QvmxS = 1. - RvmxS
QslpS = 1. - RslpS
QabsS = 1. - RabsS
!
QCV = 1. - RCV
QCVB = 1. - RCVB
QCVT = 1. - RCVT
QCNP = 1. - RCNP
!
DO K=1,LSOIL
QSMCL(K) = 1. - RSMCL(K)
QSMCS(K) = 1. - RSMCS(K)
QSTCL(K) = 1. - RSTCL(K)
QSTCS(K) = 1. - RSTCS(K)
ENDDO
!
! Merging
!
!CluX
if(me .eq. 0) then
print *, 'DBGX-- CSMCL:', (CSMCL(K),K=1,LSOIL)
print *, 'DBGX-- RSMCL:', (RSMCL(K),K=1,LSOIL)
print *, 'DBGX-- CSNOL, CSNOS:',CSNOL,CSNOS
print *, 'DBGX-- RSNOL, RSNOS:',RSNOL,RSNOS
endif
! print *, RTSFS, QTSFS, RAISS , QAISS
! *, RSNOS , QSNOS, RZORS , QZORS, RVEGS , QVEGS
! *, RvetS , QvetS, RsotS , QsotS
! *, RCV, RCVB, RCVT, QCV, QCVB, QCVT
! *, RALBS, QALBS, RALFS, QALFS
! print *, RTSFL, QTSFL, RAISL , QAISL
! *, RSNOL , QSNOL, RZORL , QZORL, RVEGL , QVEGL
! *, RvetL , QvetL, RsotL , QsotL
! *, RALBL, QALBL, RALFL, QALFL
!
!
LEN_THREAD_M = (LEN+NUM_THREADS-1) / NUM_THREADS
!
!$OMP PARALLEL DO PRIVATE(I1_T,I2_T,IT,I,K)
!!$OMP+PRIVATE(ALAMD,DENOM,RNUME,APHI,X,Y,WSUM,WSUMIV,SUM1,SUM2)
!
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)
!
DO I=I1_T,I2_T
IF(SLIANL(I).EQ.0.) THEN
!.... tsffc2 is the previous anomaly + today's climatology
! TSFFC2 = (TSFFCS(I)-TSFAN2(I))+TSFANL(I)
! TSFANL(I) = TSFFC2 *RTSFS+TSFANL(I)*QTSFS
!
TSFANL(I) = TSFFCS(I)*RTSFS + TSFANL(I)*QTSFS
! ALBANL(I) = ALBFCS(I)*RALBS + ALBANL(I)*QALBS
AISANL(I) = AISFCS(I)*RAISS + AISANL(I)*QAISS
SNOANL(I) = SNOFCS(I)*RSNOS + SNOANL(I)*QSNOS
ZORANL(I) = ZORFCS(I)*RZORS + ZORANL(I)*QZORS
VEGANL(I) = VEGFCS(I)*RVEGS + VEGANL(I)*QVEGS
vetANL(I) = vetFCS(I)*RvetS + vetANL(I)*QvetS
sotANL(I) = sotFCS(I)*RsotS + sotANL(I)*QsotS
!Cwu [+2L] add sih, sic
SIHANL(I) = SIHFCS(I)*RSIHS + SIHANL(I)*QSIHS
SICANL(I) = SICFCS(I)*RSICS + SICANL(I)*QSICS
!Clu [+4L] add vmn, vmx, slp, abs
VMNANL(I) = VMNFCS(I)*RVMNS + VMNANL(I)*QVMNS
VMXANL(I) = VMXFCS(I)*RVMXS + VMXANL(I)*QVMXS
SLPANL(I) = SLPFCS(I)*RSLPS + SLPANL(I)*QSLPS
ABSANL(I) = ABSFCS(I)*RABSS + ABSANL(I)*QABSS
!Cwu [+3L] add "SLIANL(I).GE.2" for sih, sic
!mi ELSE IF(SLIANL(I).GE.2.) THEN
!mi SIHANL(I) = SIHFCS(I)*RSIHS + SIHANL(I)*QSIHS
!mi SICANL(I) = SICFCS(I)*RSICS + SICANL(I)*QSICS
ELSE
vetANL(I) = vetFCS(I)*RvetL + vetANL(I)*QvetL
TSFANL(I) = TSFFCS(I)*RTSFL + TSFANL(I)*QTSFL
! ALBANL(I) = ALBFCS(I)*RALBL + ALBANL(I)*QALBL
AISANL(I) = AISFCS(I)*RAISL + AISANL(I)*QAISL
IF(RSNOL.GE.0)THEN
SNOANL(I) = SNOFCS(I)*RSNOL + SNOANL(I)*QSNOL
ELSE
IF(SNOANL(I).NE.0)THEN
SNOANL(I) = MAX(-SNOANL(I)/RSNOL,
& MIN(-SNOANL(I)*RSNOL, SNOFCS(I)))
ENDIF
ENDIF
ZORANL(I) = ZORFCS(I)*RZORL + ZORANL(I)*QZORL
!cggg landice start
!cggg at landice points (vegetation type 13) set the
!cggg soil type, slope type and greenness fields to flag values.
!cggg otherwise, perform merging.
IF (LANDICE .AND.
& SLIANL(I) == 1.0 .AND.
& VETANL(I) == 13.0) THEN
VEGANL(I) = 0.0
SOTANL(I) = 9.0
SLPANL(I) = 9.0
VMNANL(I) = 0.0
VMXANL(I) = 0.0
ELSE
VEGANL(I) = VEGFCS(I)*RVEGL + VEGANL(I)*QVEGL
sotANL(I) = sotFCS(I)*RsotL + sotANL(I)*QsotL
VMNANL(I) = VMNFCS(I)*RVMNL + VMNANL(I)*QVMNL
VMXANL(I) = VMXFCS(I)*RVMXL + VMXANL(I)*QVMXL
SLPANL(I) = SLPFCS(I)*RSLPL + SLPANL(I)*QSLPL
END IF
!cggg landice end
ABSANL(I) = ABSFCS(I)*RABSL + ABSANL(I)*QABSL
SIHANL(I) = SIHFCS(I)*RSIHL + SIHANL(I)*QSIHL
SICANL(I) = SICFCS(I)*RSICL + SICANL(I)*QSICL
ENDIF
CNPANL(I) = CNPFCS(I)*RCNP + CNPANL(I)*QCNP
!
! snow over sea ice is cycled
!
if(slianl(i).eq.2.) then
snoanl(i) = snofcs(i)
endif
ENDDO
DO I=I1_T,I2_T
CVANL(I) = CVFCS(I)*RCV + CVANL(I)*QCV
CVBANL(I) = CVBFCS(I)*RCVB + CVBANL(I)*QCVB
CVTANL(I) = CVTFCS(I)*RCVT + CVTANL(I)*QCVT
ENDDO
!
DO K = 1, 4
DO I=I1_T,I2_T
IF(SLIANL(I).EQ.0.) THEN
ALBANL(I,K) = ALBFCS(I,K)*RALBS + ALBANL(I,K)*QALBS
ELSE
ALBANL(I,K) = ALBFCS(I,K)*RALBL + ALBANL(I,K)*QALBL
ENDIF
ENDDO
ENDDO
!
DO K = 1, 2
DO I=I1_T,I2_T
IF(SLIANL(I).EQ.0.) THEN
ALFANL(I,K) = ALFFCS(I,K)*RALFS + ALFANL(I,K)*QALFS
ELSE
ALFANL(I,K) = ALFFCS(I,K)*RALFL + ALFANL(I,K)*QALFL
ENDIF
ENDDO
ENDDO
!
DO K = 1, LSOIL
DO I=I1_T,I2_T
IF(SLIANL(I).EQ.0.) THEN
SMCANL(I,K) = SMCFCS(I,K)*RSMCS(K) + SMCANL(I,K)*QSMCS(K)
STCANL(I,K) = STCFCS(I,K)*RSTCS(K) + STCANL(I,K)*QSTCS(K)
ELSE
!cggg landice start soil moisture not used at landice points, so
!cggg don't bother merging it. also, for now don't allow nudging
!cggg to raise subsurface temperature above freezing.
STCANL(I,K) = STCFCS(I,K)*RSTCL(K) + STCANL(I,K)*QSTCL(K)
IF (LANDICE .AND. SLIANL(I) == 1.0 .AND.
& VETANL(I) == 13.0) THEN
SMCANL(I,K) = 1.0 ! use value as flag
STCANL(I,K) = MIN(STCANL(I,K), 273.15)
ELSE
SMCANL(I,K) = SMCFCS(I,K)*RSMCL(K) + SMCANL(I,K)*QSMCL(K)
END IF
!cggg landice end
ENDIF
ENDDO
ENDDO
!
ENDDO ! END OF THREADED LOOP ...................
!$OMP END PARALLEL DO
RETURN
END
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,
& smcice,tsfmin,zorsea,smcsea
!Cwu [+1L] add sicnew,sihnew
&, sicnew,sihnew
integer i,me,kount1,kount2,k,len,lsoil
REAL (KIND=KIND_IO8) SLIANL(LEN), SLIFCS(LEN),
& TSFFCS(LEN),TSFANL(LEN)
REAL (KIND=KIND_IO8) ALBANL(LEN,4), SNOANL(LEN), ZORANL(LEN)
REAL (KIND=KIND_IO8) SMCANL(LEN,LSOIL), STCANL(LEN,LSOIL)
!Cwu [+1L] add sihanl & sicanl
REAL (KIND=KIND_IO8) SIHANL(LEN), SICANL(LEN)
!
REAL (KIND=KIND_IO8) RLA(LEN), RLO(LEN)
!
if (me .eq. 0) WRITE(6,*) 'NEWICE'
!
KOUNT1 = 0
KOUNT2 = 0
DO I=1,LEN
IF(SLIFCS(I).NE.SLIANL(I)) THEN
IF(SLIFCS(I).EQ.1..OR.SLIANL(I).EQ.1.) THEN
PRINT *,'INCONSISTENCY IN SLIFCS OR SLIANL'
PRINT 910,RLA(I),RLO(I),SLIFCS(I),SLIANL(I),
& TSFFCS(I),TSFANL(I)
910 FORMAT(2X,'AT LAT=',F5.1,' LON=',F5.1,' SLIFCS=',F4.1,
& ' SLIMSK=',F4.1,' TSFFCS=',F5.1,' SET TO TSFANL=',F5.1)
CALL ABORT
ENDIF
!
! INTERPOLATED CLIMATOLOGY INDICATES MELTED SEA ICE
!
IF(SLIANL(I).EQ.0..AND.SLIFCS(I).EQ.2.) THEN
TSFANL(I) = TSFMIN
ALBANL(I,1) = ALBSEA
ALBANL(I,2) = ALBSEA
ALBANL(I,3) = ALBSEA
ALBANL(I,4) = ALBSEA
SNOANL(I) = SNOSEA
ZORANL(I) = ZORSEA
DO K = 1, LSOIL
SMCANL(I,K) = SMCSEA
!Cwu [+1L] set STCANL to TGICE (over SEA-ICE)
STCANL(I,K) = TGICE
ENDDO
!Cwu [+2L] set siganl and sicanl
SIHANL(I) = 0.
SICANL(I) = 0.
KOUNT1 = KOUNT1 + 1
ENDIF
!
! INTERPLATED CLIMATOLOYG/ANALYSIS INDICATES NEW SEA ICE
!
IF(SLIANL(I).EQ.2..AND.SLIFCS(I).EQ.0.) THEN
TSFANL(I) = TSFICE
ALBANL(I,1) = ALBICE
ALBANL(I,2) = ALBICE
ALBANL(I,3) = ALBICE
ALBANL(I,4) = ALBICE
SNOANL(I) = 0.
ZORANL(I) = ZORICE
DO K = 1, LSOIL
SMCANL(I,K) = SMCICE
STCANL(I,K) = TGICE
ENDDO
!Cwu [+2L] add SIHANL & SICANL
SIHANL(I) = SIHNEW
SICANL(I) = min(one, max(SICNEW,SICANL(i)))
KOUNT2 = KOUNT2 + 1
ENDIF
ENDIF
ENDDO
!
if (me .eq. 0) then
IF(KOUNT1.GT.0) THEN
WRITE(6,*) 'Sea ice melted. TSF,ALB,ZOR are filled',
& ' at ',KOUNT1,' points'
ENDIF
IF(KOUNT2.GT.0) THEN
WRITE(6,*) 'Sea ice formed. TSF,ALB,ZOR are filled',
& ' at ',KOUNT2,' points'
ENDIF
endif
!
RETURN
END
!cggg landice mods start
! SUBROUTINE QCSNOW(SNOANL,SLMASK,AISANL,GLACIR,LEN,SNOVAL,me)
SUBROUTINE QCSNOW(SNOANL,SLMASK,AISANL,GLACIR,LEN,SNOVAL,
& LANDICE,me)
!cggg landice mods end
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer kount,i,len,me
!cggg landice mods start
LOGICAL, INTENT(IN) :: LANDICE
!cggg landice mods end
REAL (KIND=KIND_IO8) per,snoval
REAL (KIND=KIND_IO8) SNOANL(LEN),SLMASK(LEN),
& AISANL(LEN),GLACIR(LEN)
if (me .eq. 0) then
WRITE(6,*) ' '
WRITE(6,*) 'QC of SNOW'
endif
!cggg landice mods start
IF (.NOT.LANDICE) THEN
!cggg landice mods end
KOUNT=0
DO I=1,LEN
IF(GLACIR(I).NE.0..AND.SNOANL(I).EQ.0.) THEN
! IF(GLACIR(I).NE.0..AND.SNOANL(I).LT.SNOVAL*0.5) THEN
SNOANL(I) = SNOVAL
KOUNT = KOUNT + 1
ENDIF
ENDDO
PER = FLOAT(KOUNT) / FLOAT(LEN)*100.
IF(KOUNT.GT.0) THEN
if (me .eq. 0) then
PRINT *,'SNOW filled over glacier points at ',KOUNT,
& ' POINTS (',PER,'percent)'
endif
ENDIF
!cggg landice mods start
ENDIF ! LANDICE CHECK
!cggg landice mods end
KOUNT = 0
DO I=1,LEN
IF(SLMASK(I).EQ.0.AND.AISANL(I).EQ.0) THEN
SNOANL(I) = 0.
KOUNT = KOUNT + 1
ENDIF
ENDDO
PER = FLOAT(KOUNT) / FLOAT(LEN)*100.
IF(KOUNT.GT.0) THEN
if (me .eq. 0) then
PRINT *,'SNOW set to zero over open sea at ',KOUNT,
& ' POINTS (',PER,'percent)'
endif
ENDIF
RETURN
END
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),
& AMXICE(LEN), SLMASK(LEN)
REAL (KIND=KIND_IO8) RLA(LEN), RLO(LEN)
!
! CHECK SEA-ICE COVER MASK AGAINST LAND-SEA MASK
!
if (me .eq. 0) WRITE(6,*) 'QC of sea ice'
KOUNT = 0
KOUNT1 = 0
DO I=1,LEN
IF(AIS(I).NE.AICICE.AND.AIS(I).NE.AICSEA) THEN
PRINT *,'SEA ICE MASK NOT ',AICICE,' OR ',AICSEA
PRINT *,'AIS(I),AICICE,AICSEA,RLA(I),RLO(I,=',
& AIS(I),AICICE,AICSEA,RLA(I),RLO(I)
CALL ABORT
ENDIF
IF(SLMASK(I).EQ.0..AND.GLACIR(I).EQ.1..AND.
! IF(SLMASK(I).EQ.0..AND.GLACIR(I).EQ.2..AND.
& AIS(I).NE.1.) THEN
KOUNT1 = KOUNT1 + 1
AIS(I) = 1.
ENDIF
IF(SLMASK(I).EQ.SLLND.AND.AIS(I).EQ.AICICE) THEN
KOUNT = KOUNT + 1
AIS(I) = AICSEA
ENDIF
ENDDO
! ENDDO
PER = FLOAT(KOUNT) / FLOAT(LEN)*100.
IF(KOUNT.GT.0) THEN
if(me .eq. 0) then
PRINT *,' Sea ice over land mask at ',KOUNT,' points (',PER,
& 'percent)'
endif
ENDIF
PER = FLOAT(KOUNT1) / FLOAT(LEN)*100.
IF(KOUNT1.GT.0) THEN
if(me .eq. 0) then
PRINT *,' Sea ice set over glacier points over ocean at ',
& KOUNT1,' points (',PER,'percent)'
endif
ENDIF
! KOUNT=0
! DO J=1,JDIM
! DO I=1,IDIM
! IF(AMXICE(I,J).NE.0..AND.AIS(I,J).EQ.0.) THEN
! AIS(I,J)=0.
! KOUNT=KOUNT+1
! ENDIF
! ENDDO
! ENDDO
! PER=FLOAT(KOUNT)/FLOAT(IDIM*JDIM)*100.
! IF(KOUNT.GT.0) THEN
! PRINT *,' Sea ice exceeds maxice at ',KOUNT,' points (',PER,
! & 'percent)'
! ENDIF
!
! Remove isolated open ocean surrounded by sea ice and/or land
!
! Remove isolated open ocean surrounded by sea ice and/or land
!
! IJ = 0
! DO J=1,JDIM
! DO I=1,IDIM
! IJ = IJ + 1
! IP = I + 1
! IM = I - 1
! JP = J + 1
! JM = J - 1
! IF(JP.GT.JDIM) JP = JDIM - 1
! IF(JM.LT.1) JM = 2
! IF(IP.GT.IDIM) IP = 1
! IF(IM.LT.1) IM = IDIM
! IF(SLMASK(I,J).EQ.0..AND.AIS(I,J).EQ.0.) THEN
! IF((SLMASK(IP,JP).EQ.1..OR.AIS(IP,JP).EQ.1.).AND.
! & (SLMASK(I ,JP).EQ.1..OR.AIS(I ,JP).EQ.1.).AND.
! & (SLMASK(IM,JP).EQ.1..OR.AIS(IM,JP).EQ.1.).AND.
! & (SLMASK(IP,J ).EQ.1..OR.AIS(IP,J ).EQ.1.).AND.
! & (SLMASK(IM,J ).EQ.1..OR.AIS(IM,J ).EQ.1.).AND.
! & (SLMASK(IP,JM).EQ.1..OR.AIS(IP,JM).EQ.1.).AND.
! & (SLMASK(I ,JM).EQ.1..OR.AIS(I ,JM).EQ.1.).AND.
! & (SLMASK(IM,JM).EQ.1..OR.AIS(IM,JM).EQ.1.)) THEN
! AIS(I,J) = 1.
! WRITE(6,*) ' Isolated open sea point surrounded by',
! & ' sea ice or land modified to sea ice',
! & ' at LAT=',RLA(I,J),' LON=',RLO(I,J)
! ENDIF
! ENDIF
! ENDDO
! ENDDO
RETURN
END
SUBROUTINE SETLSI(SLMASK,AISFLD,LEN,AICICE,SLIFLD)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,len
REAL (KIND=KIND_IO8) aicice
REAL (KIND=KIND_IO8) SLMASK(LEN), SLIFLD(LEN), AISFLD(LEN)
!
! Set surface condition indicator slimsk
!
DO I=1,LEN
SLIFLD(I) = SLMASK(I)
! IF(AISFLD(I).EQ.AICICE) SLIFLD(I) = 2.0
IF(AISFLD(I).EQ.AICICE .AND. SLMASK(I) .EQ. 0.0)
& SLIFLD(I) = 2.0
ENDDO
RETURN
END
SUBROUTINE SCALE(FLD,LEN,SCL)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,len
REAL (KIND=KIND_IO8) FLD(LEN),scl
DO I=1,LEN
FLD(I) = FLD(I) * SCL
ENDDO
RETURN
END
SUBROUTINE QCMXMN(TTL,FLD,SLIMSK,SNO,ICEFLG,
& FLDLMX,FLDLMN,FLDOMX,FLDOMN,FLDIMX,FLDIMN,
& FLDJMX,FLDJMN,FLDSMX,FLDSMN,EPSFLD,
& RLA,RLO,LEN,MODE,PERCRIT,LGCHEK,me)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
REAL (KIND=KIND_IO8) permax,per,fldimx,fldimn,fldjmx,fldomn,
& fldlmx,fldlmn,fldomx,fldjmn,percrit,
& fldsmx,fldsmn,epsfld
integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj,
& ij,nprt,kmaxs,kmins,i,me,len,mode
PARAMETER(MMPRT=2)
!
CHARACTER*8 TTL
logical iceflg(LEN)
REAL (KIND=KIND_IO8) FLD(LEN),SLIMSK(LEN),SNO(LEN),
& RLA(LEN), RLO(LEN)
INTEGER IWK(LEN)
LOGICAL LGCHEK
!
logical first
integer NUM_THREADS
data first /.true./
save NUM_THREADS, first
!
integer LEN_THREAD_M, I1_T, I2_T, IT
integer NUM_PARTHDS
!
if (first) then
NUM_THREADS = NUM_PARTHDS()
first = .false.
endif
!
! CHECK AGAINST LAND-SEA MASK AND ICE COVER MASK
!
if(me .eq. 0) then
! PRINT *,' '
PRINT *,'Performing QC of ',TTL,' MODE=',MODE,
& '(0=count only, 1=replace)'
endif
!
LEN_THREAD_M = (LEN+NUM_THREADS-1) / NUM_THREADS
!
!$OMP PARALLEL DO PRIVATE(I1_T,I2_T,IT,I)
!$OMP+PRIVATE(nprt,ij,iwk,KMAXS,KMINS)
!$OMP+PRIVATE(KMAXL,KMINL,KMAXO,KMINO,KMAXI,KMINI,KMAXJ,KMINJ)
!$OMP+SHARED(mode,epsfld)
!$OMP+SHARED(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn)
!$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)
!
KMAXL = 0
KMINL = 0
KMAXO = 0
KMINO = 0
KMAXI = 0
KMINI = 0
KMAXJ = 0
KMINJ = 0
KMAXS = 0
KMINS = 0
!
!
! Lower bound check over bare land
!
IF (FLDLMN .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.1..AND.SNO(I).LE.0..AND.
& FLD(I).LT.FLDLMN-EPSFLD) THEN
KMINL=KMINL+1
IWK(KMINL) = I
ENDIF
ENDDO
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,
& ' LON=',F6.1,' FLD=',E13.6, ' to ',E13.6)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMINL
FLD(IWK(I)) = FLDLMN
ENDDO
ENDIF
ENDIF
!
! Upper bound check over bare land
!
IF (FLDLMX .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.1..AND.SNO(I).LE.0..AND.
& FLD(I).GT.FLDLMX+EPSFLD) THEN
KMAXL=KMAXL+1
IWK(KMAXL) = I
ENDIF
ENDDO
if(me == 0 . and. it == 1 .and. NUM_THREADS == 1) then
NPRT = MIN(MMPRT,KMAXL)
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,
& ' LON=',F6.1,' FLD=',E13.6, ' to ',E13.6)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMAXL
FLD(IWK(I)) = FLDLMX
ENDDO
ENDIF
ENDIF
!
! Lower bound check over snow covered land
!
IF (FLDSMN .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.1..AND.SNO(I).GT.0..AND.
& FLD(I).LT.FLDSMN-EPSFLD) THEN
KMINS=KMINS+1
IWK(KMINS) = I
ENDIF
ENDDO
if(me == 0 . and. it == 1 .and. NUM_THREADS == 1) then
NPRT = MIN(MMPRT,KMINS)
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,
& ' LON=',F6.1,' FLD=',E11.4, ' to ',E11.4)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMINS
FLD(IWK(I)) = FLDSMN
ENDDO
ENDIF
ENDIF
!
! Upper bound check over snow covered land
!
IF (FLDSMX .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.1..AND.SNO(I).GT.0..AND.
& FLD(I).GT.FLDSMX+EPSFLD) THEN
KMAXS=KMAXS+1
IWK(KMAXS) = I
ENDIF
ENDDO
if(me == 0 . and. it == 1 .and. NUM_THREADS == 1) then
NPRT = MIN(MMPRT,KMAXS)
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,
& ' LON=',F6.1,' FLD=',E11.4, ' to ',E11.4)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMAXS
FLD(IWK(I)) = FLDSMX
ENDDO
ENDIF
ENDIF
!
! Lower bound check over open ocean
!
IF (FLDOMN .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.0..AND.
& FLD(I).LT.FLDOMN-EPSFLD) THEN
KMINO=KMINO+1
IWK(KMINO) = I
ENDIF
ENDDO
if(me == 0 . and. it == 1 .and. NUM_THREADS == 1) then
NPRT = MIN(MMPRT,KMINO)
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,
& ' LON=',F6.1,' FLD=',E11.4,' to ',E11.4)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMINO
FLD(IWK(I)) = FLDOMN
ENDDO
ENDIF
ENDIF
!
! Upper bound check over open ocean
!
IF (FLDOMX .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(FLDOMX.NE.999..AND.SLIMSK(I).EQ.0..AND.
& FLD(I).GT.FLDOMX+EPSFLD) THEN
KMAXO=KMAXO+1
IWK(KMAXO) = I
ENDIF
ENDDO
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,
& ' LON=',F6.1,' FLD=',E11.4, ' to ',E11.4)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMAXO
FLD(IWK(I)) = FLDOMX
ENDDO
ENDIF
ENDIF
!
! Lower bound check over sea ice without snow
!
IF (FLDIMN .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.2..AND.SNO(I).LE.0..AND.
& FLD(I).LT.FLDIMN-EPSFLD) THEN
KMINI=KMINI+1
IWK(KMINI) = I
ENDIF
ENDDO
if(me == 0 . and. it == 1 .and. NUM_THREADS == 1) then
NPRT = MIN(MMPRT,KMINI)
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,
& ' LON=',F6.1,' FLD=',E11.4, ' to ',E11.4)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMINI
FLD(IWK(I)) = FLDIMN
ENDDO
ENDIF
ENDIF
!
! Upper bound check over sea ice without snow
!
IF (FLDIMX .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.2..AND.SNO(I).LE.0..AND.
& FLD(I).GT.FLDIMX+EPSFLD .AND. ICEFLG(I)) THEN
! & FLD(I).GT.FLDIMX+EPSFLD) THEN
KMAXI=KMAXI+1
IWK(KMAXI) = I
ENDIF
ENDDO
if(me == 0 . and. it == 1 .and. NUM_THREADS == 1) then
NPRT = MIN(MMPRT,KMAXI)
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,
& ' LON=',F6.1,' FLD=',E11.4, ' to ',E11.4)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMAXI
FLD(IWK(I)) = FLDIMX
ENDDO
ENDIF
ENDIF
!
! Lower bound check over sea ice with snow
!
IF (FLDJMN .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.2..AND.SNO(I).GT.0..AND.
& FLD(I).LT.FLDJMN-EPSFLD) THEN
KMINJ=KMINJ+1
IWK(KMINJ) = I
ENDIF
ENDDO
if(me == 0 . and. it == 1 .and. NUM_THREADS == 1) then
NPRT = MIN(MMPRT,KMINJ)
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,
& ' LON=',F6.1,' FLD=',E11.4, ' to ',E11.4)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMINJ
FLD(IWK(I)) = FLDJMN
ENDDO
ENDIF
ENDIF
!
! Upper bound check over sea ice with snow
!
IF (FLDJMX .NE. 999.0) THEN
DO I=I1_T,I2_T
IF(SLIMSK(I).EQ.2..AND.SNO(I).GT.0..AND.
& FLD(I).GT.FLDJMX+EPSFLD .AND. ICEFLG(I)) THEN
! & FLD(I).GT.FLDJMX+EPSFLD) THEN
KMAXJ=KMAXJ+1
IWK(KMAXJ) = I
ENDIF
ENDDO
if(me == 0 . and. it == 1 .and. NUM_THREADS == 1) then
NPRT = MIN(MMPRT,KMAXJ)
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,
& ' LON=',F6.1,' FLD=',E11.4, ' to ',E11.4)
ENDDO
endif
IF (MODE .EQ. 1) THEN
DO I=1,KMAXJ
FLD(IWK(I)) = FLDJMX
ENDDO
ENDIF
ENDIF
ENDDO ! END OF THREADED LOOP ...................
!$OMP END PARALLEL DO
!
! Print results
!
if(me .eq. 0) then
! WRITE(6,*) 'SUMMARY OF QC'
PERMAX=0.
IF(KMINL.GT.0) THEN
PER=FLOAT(KMINL)/FLOAT(LEN)*100.
PRINT 9001,FLDLMN,KMINL,PER
9001 FORMAT(' Bare land min check. Modified to ',F8.1,
& ' at ',I5,' points ',F8.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
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,
& ' at ',I5,' points ',F4.1,'percent')
IF(PER.GT.PERMAX) PERMAX=PER
ENDIF
! Commented on 06/30/99 -- Moorthi
! IF(LGCHEK) THEN
! IF(PERMAX.GT.PERCRIT) THEN
! WRITE(6,*) ' Too many bad points. Aborting ....'
! CALL ABORT
! ENDIF
! ENDIF
!
endif
!
RETURN
END
SUBROUTINE SETZRO(FLD,EPS,LEN)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,len
REAL (KIND=KIND_IO8) FLD(LEN),eps
DO I=1,LEN
IF(ABS(FLD(I)).LT.EPS) FLD(I) = 0.
ENDDO
RETURN
END
SUBROUTINE GETSCV(SNOFLD,SCVFLD,LEN)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,len
REAL (KIND=KIND_IO8) SNOFLD(LEN),SCVFLD(LEN)
!
DO I=1,LEN
SCVFLD(I) = 0.
IF(SNOFLD(I).GT.0.) SCVFLD(I) = 1.
ENDDO
RETURN
END
SUBROUTINE GETSTC(TSFFLD,TG3FLD,SLIFLD,LEN,LSOIL,STCFLD,TSFIMX)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer k,i,len,lsoil
REAL (KIND=KIND_IO8) factor,tsfimx
REAL (KIND=KIND_IO8) TSFFLD(LEN), TG3FLD(LEN), SLIFLD(LEN)
REAL (KIND=KIND_IO8) STCFLD(LEN,LSOIL)
!
! Layer Soil temperature
!
DO K = 1, LSOIL
DO I = 1, LEN
IF(SLIFLD(I).EQ.1.0) THEN
FACTOR = ((K-1) * 2 + 1) / (2. * LSOIL)
STCFLD(I,K) = FACTOR*TG3FLD(I)+(1.-FACTOR)*TSFFLD(I)
ELSEIF(SLIFLD(I).EQ.2.0) THEN
FACTOR = ((K-1) * 2 + 1) / (2. * LSOIL)
STCFLD(I,K) = FACTOR*TSFIMX+(1.-FACTOR)*TSFFLD(I)
ELSE
STCFLD(I,K) = TG3FLD(I)
ENDIF
ENDDO
ENDDO
IF(LSOIL.GT.2) THEN
DO K = 3, LSOIL
DO I = 1, LEN
STCFLD(I,K) = STCFLD(I,2)
ENDDO
ENDDO
ENDIF
RETURN
END
SUBROUTINE GETSMC(WETFLD,LEN,LSOIL,SMCFLD,me)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer k,i,len,lsoil,me
REAL (KIND=KIND_IO8) WETFLD(LEN), SMCFLD(LEN,LSOIL)
!
if (me .eq. 0) WRITE(6,*) 'GETSMC'
!
! Layer Soil wetness
!
DO K = 1, LSOIL
DO I = 1, LEN
SMCFLD(I,K) = (WETFLD(I)*1000./150.)*.37 + .1
ENDDO
ENDDO
RETURN
END
SUBROUTINE USESGT(SIG1T,SLIANL,TG3ANL,LEN,LSOIL,TSFANL,STCANL,
& TSFIMX)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,len,lsoil
REAL (KIND=KIND_IO8) tsfimx
REAL (KIND=KIND_IO8) SIG1T(LEN), SLIANL(LEN), TG3ANL(LEN)
REAL (KIND=KIND_IO8) TSFANL(LEN), STCANL(LEN,LSOIL)
!
! Soil temperature
!
IF(SIG1T(1).GT.0.) THEN
DO I=1,LEN
IF(SLIANL(I).NE.0.) THEN
TSFANL(I) = SIG1T(I)
ENDIF
ENDDO
ENDIF
CALL GETSTC(TSFANL,TG3ANL,SLIANL,LEN,LSOIL,STCANL,TSFIMX)
!
RETURN
END
SUBROUTINE SNOSFC(SNOANL,TSFANL,TSFSMX,LEN,me)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer kount,i,len,me
REAL (KIND=KIND_IO8) per,tsfsmx
REAL (KIND=KIND_IO8) SNOANL(LEN), TSFANL(LEN)
!
if (me .eq. 0) WRITE(6,*) 'Set snow temp to TSFSMX if greater'
KOUNT=0
DO I=1,LEN
IF(SNOANL(I).GT.0.) THEN
IF(TSFANL(I).GT.TSFSMX) TSFANL(I)=TSFSMX
KOUNT = KOUNT + 1
ENDIF
ENDDO
IF(KOUNT.GT.0) THEN
if(me .eq. 0) then
PER=FLOAT(KOUNT)/FLOAT(LEN)*100.
WRITE(6,*) 'Snow sfc. TSF set to ',TSFSMX,' at ',
& KOUNT, ' POINTS ',PER,'percent'
endif
ENDIF
RETURN
END
SUBROUTINE ALBOCN(ALBCLM,SLMASK,ALBOMX,LEN)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,len
REAL (KIND=KIND_IO8) albomx
REAL (KIND=KIND_IO8) ALBCLM(LEN,4), SLMASK(LEN)
DO I=1,LEN
IF(SLMASK(I).EQ.0) THEN
ALBCLM(I,1) = ALBOMX
ALBCLM(I,2) = ALBOMX
ALBCLM(I,3) = ALBOMX
ALBCLM(I,4) = ALBOMX
ENDIF
ENDDO
RETURN
END
SUBROUTINE QCMXICE(GLACIR,AMXICE,LEN,me)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,kount,len,me
REAL (KIND=KIND_IO8) GLACIR(LEN),AMXICE(LEN),per
if (me .eq. 0) WRITE(6,*) 'QC of maximum ice extent'
KOUNT=0
DO I=1,LEN
IF(GLACIR(I).EQ.1..AND.AMXICE(I).EQ.0.) THEN
AMXICE(I) = 0.
KOUNT = KOUNT + 1
ENDIF
ENDDO
IF(KOUNT.GT.0) THEN
PER = FLOAT(KOUNT) / FLOAT(LEN)*100.
if(me .eq. 0) WRITE(6,*) ' Max ice limit less than glacier'
&, ' coverage at ', KOUNT, ' POINTS ',PER,'percent'
ENDIF
RETURN
END
SUBROUTINE QCSLI(SLIANL,SLIFCS,LEN,me)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,kount,len,me
REAL (KIND=KIND_IO8) SLIANL(LEN), SLIFCS(LEN),per
if (me .eq. 0) then
WRITE(6,*) ' '
WRITE(6,*) 'QCSLI'
endif
KOUNT=0
DO I=1,LEN
IF(SLIANL(I).EQ.1..AND.SLIFCS(I).EQ.0.) THEN
KOUNT = KOUNT + 1
SLIFCS(I) = 1.
ENDIF
IF(SLIANL(I).EQ.0..AND.SLIFCS(I).EQ.1.) THEN
KOUNT = KOUNT + 1
SLIFCS(I) = 0.
ENDIF
IF(SLIANL(I).EQ.2..AND.SLIFCS(I).EQ.1.) THEN
KOUNT = KOUNT + 1
SLIFCS(I) = 0.
ENDIF
IF(SLIANL(I).EQ.1..AND.SLIFCS(I).EQ.2.) THEN
KOUNT = KOUNT + 1
SLIFCS(I) = 1.
ENDIF
ENDDO
IF(KOUNT.GT.0) THEN
PER=FLOAT(KOUNT)/FLOAT(LEN)*100.
if(me .eq. 0) then
WRITE(6,*) ' Inconsistency of SLMASK between forecast and',
& ' analysis corrected at ',KOUNT, ' POINTS ',PER,
& 'percent'
endif
ENDIF
RETURN
END
! SUBROUTINE NNTPRT(DATA,IMAX,FACT)
! REAL (KIND=KIND_IO8) DATA(IMAX)
! ILAST=0
! I1=1
! I2=80
!1112 CONTINUE
! IF(I2.GE.IMAX) THEN
! ILAST=1
! I2=IMAX
! ENDIF
! WRITE(6,*) ' '
! DO J=1,JMAX
! WRITE(6,1111) (NINT(DATA(IMAX*(J-1)+I)*FACT),I=I1,I2)
! ENDDO
! IF(ILAST.EQ.1) RETURN
! I1=I1+80
! I2=I1+79
! IF(I2.GE.IMAX) THEN
! ILAST=1
! I2=IMAX
! ENDIF
! GO TO 1112
!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)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer kount,me,k,i,lsoil,len
REAL (KIND=KIND_IO8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx
REAL (KIND=KIND_IO8) TSFFCS(LEN), SNOFCS(LEN)
REAL (KIND=KIND_IO8) SNOANL(LEN), AISANL(LEN),
& SLIANL(LEN), ZORANL(LEN),
& TSFANL(LEN), ALBANL(LEN,4),
& SMCANL(LEN,LSOIL)
REAL (KIND=KIND_IO8) SMCCLM(LEN,LSOIL)
!
if (me .eq. 0) WRITE(6,*) 'QC of snow and sea-ice ANALYSIS'
!
! QC of snow analysis
!
! Questionable snow cover
!
KOUNT = 0
DO I=1,LEN
IF(SLIANL(I).GT.0..AND.
& TSFFCS(I).GT.QCTSFS.AND.SNOANL(I).GT.0.) THEN
KOUNT = KOUNT + 1
SNOANL(I) = 0.
TSFANL(I) = TSFFCS(I)
ENDIF
ENDDO
IF(KOUNT.GT.0) THEN
PER=FLOAT(KOUNT)/FLOAT(LEN)*100.
if (me .eq. 0) then
WRITE(6,*) ' Guess surface temp .GT. ',QCTSFS,
& ' but snow analysis indicates snow cover'
WRITE(6,*) ' Snow analysis set to zero',
& ' at ',KOUNT, ' POINTS ',PER,'percent'
endif
ENDIF
!
! Questionable no snow cover
!
KOUNT = 0
DO I=1,LEN
IF(SLIANL(I).GT.0..AND.
& SNOFCS(I).GT.QCSNOS.AND.SNOANL(I).LT.0.) THEN
KOUNT = KOUNT + 1
SNOANL(I) = SNOFCS(I)
TSFANL(I) = TSFFCS(I)
ENDIF
ENDDO
IF(KOUNT.GT.0) THEN
PER=FLOAT(KOUNT)/FLOAT(LEN)*100.
if (me .eq. 0) then
WRITE(6,*) ' Guess snow depth .GT. ',QCSNOS,
& ' but snow analysis indicates no snow cover'
WRITE(6,*) ' Snow analysis set to guess value',
& ' at ',KOUNT, ' POINTS ',PER,'percent'
endif
ENDIF
!
! Questionable sea ice cover ! This QC is disable to correct error in
! surface temparature over observed sea ice points
!
! KOUNT = 0
! DO I=1,LEN
! IF(SLIANL(I).EQ.2..AND.
! & TSFFCS(I).GT.QCTSFI.AND.AISANL(I).EQ.1.) THEN
! KOUNT = KOUNT + 1
! AISANL(I) = 0.
! SLIANL(I) = 0.
! TSFANL(I) = TSFFCS(I)
! SNOANL(I) = 0.
! ZORANL(I) = ZOROMX
! ALBANL(I,1) = ALBOMX
! ALBANL(I,2) = ALBOMX
! ALBANL(I,3) = ALBOMX
! ALBANL(I,4) = ALBOMX
! DO K=1,LSOIL
! SMCANL(I,K) = SMCCLM(I,K)
! ENDDO
! ENDIF
! ENDDO
! IF(KOUNT.GT.0) THEN
! PER=FLOAT(KOUNT)/FLOAT(LEN)*100.
! if (me .eq. 0) then
! WRITE(6,*) ' Guess surface temp .GT. ',QCTSFI,
! & ' but sea-ice analysis indicates sea-ice'
! WRITE(6,*) ' Sea-ice analysis set to zero',
! & ' at ',KOUNT, ' POINTS ',PER,'percent'
! endif
! ENDIF
!
RETURN
END
SUBROUTINE SETRMSK(KPDS5,SLMASK,IGAUL,JGAUL,WLON,RNLAT,
& DATA,IMAX,JMAX,RLNOUT,RLTOUT,LMASK,RSLMSK
! & DATA,IMAX,JMAX,DLON,DLAT,LMASK,RSLMSK
!cggg &, GAUS,BLNO, BLTO, kgds1)
&, GAUS,BLNO, BLTO, kgds1, kpds4, lbms)
USE MACHINE , ONLY : kind_io8,kind_io4
USE sfccyc_module
implicit none
REAL (KIND=KIND_IO8) blno,blto,wlon,rnlat,crit,data_max
! REAL (KIND=KIND_IO8) blno,dlat,dlon,blto,wlon,rnlat,crit
integer i,j,ijmax,jgaul,igaul,kpds5,jmax,imax, kgds1, kspla
!cggg
integer, intent(in) :: kpds4
logical*1, intent(in) :: lbms(imax,jmax)
real*4 :: dummy(imax,jmax)
REAL (KIND=KIND_IO8) SLMASK(IGAUL,JGAUL)
REAL (KIND=KIND_IO8) DATA(IMAX,JMAX),RSLMSK(IMAX,JMAX)
&, RLNOUT(IMAX), RLTOUT(JMAX)
REAL (KIND=KIND_IO8) A(JMAX), W(JMAX), RADI, dlat, dlon
LOGICAL LMASK, GAUS
!
! Integer kpdalb(4), kpdalf(2)
! data kpdalb/212,215,213,216/, kpdalf/214,217/
! save kpdalb, kpdalf
!
! Set the longitude and latitudes for the grib file
!
if (kgds1 .eq. 4) then ! grib file on Gaussian grid
KSPLA=4
CALL SPLAT(KSPLA, JMAX, A, W)
!
RADI = 180.0 / (4.*ATAN(1.))
DO J=1,JMAX
RLTOUT(J) = ACOS(A(J)) * RADI
ENDDO
!
if (rnlat .gt. 0.0) then
DO J=1,JMAX
RLTOUT(J) = 90. - RLTOUT(J)
ENDDO
else
DO J=1,JMAX
RLTOUT(J) = -90. + RLTOUT(J)
ENDDO
endif
elseif (kgds1 .eq. 0) then ! grib file on lat/lon grid
DLAT = -(RNLAT+RNLAT) / FLOAT(JMAX-1)
DO J=1,JMAX
RLTOUT(J) = RNLAT + (J-1) * DLAT
ENDDO
else ! grib file on some other grid
call abort
endif
dlon = 360.0 / imax
DO I=1,IMAX
RLNOUT(I) = WLON + (I-1)*DLON
ENDDO
!
!
IJMAX = IMAX*JMAX
RSLMSK = 0.
!
! Surface temperature
!
IF(KPDS5.EQ.KPDTSF) THEN
! LMASK=.FALSE.
CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
&, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
CRIT=0.5
CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
LMASK=.TRUE.
!
! Bucket soil wetness
!
ELSEIF(KPDS5.EQ.KPDWET) THEN
CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
&, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
CRIT=0.5
CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
LMASK=.TRUE.
! WRITE(6,*) 'WET RSLMSK'
! ZNNT=1.
! CALL NNTPRT(RSLMSK,IJMAX,ZNNT)
!
! Snow depth
!
!cggg snow mods start
ELSEIF(KPDS5.EQ.KPDSND) THEN
print*,'get mask for snow depth data'
IF(KPDS4 == 192) THEN ! USE THE BITMAP
print*,'use bitmap for snow'
RSLMSK = 0.
DO J = 1, JMAX
DO I = 1, IMAX
IF (LBMS(I,J)) THEN
RSLMSK(I,J) = 1.
END IF
ENDDO
ENDDO
LMASK=.TRUE.
ELSE
LMASK=.FALSE.
END IF
!cggg snow mods end
!
! SNOW LIQ EQUIVALENT DEPTH
!
ELSEIF(KPDS5.EQ.KPDSNO) THEN
CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
&, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
CRIT=0.5
CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
LMASK=.TRUE.
! WRITE(6,*) 'SNO RSLMSK'
! ZNNT=1.
! CALL NNTPRT(RSLMSK,IJMAX,ZNNT)
!
! Soil Moisture
!
ELSEIF(KPDS5.EQ.KPDSMC) THEN
CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
&, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
CRIT=0.5
CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
LMASK=.TRUE.
!
! Surface roughness
!
ELSEIF(KPDS5.EQ.KPDZOR) THEN
DO J=1,JMAX
DO I=1,IMAX
RSLMSK(I,J)=DATA(I,J)
ENDDO
ENDDO
CRIT=9.9
CALL ROF01(RSLMSK,IJMAX,'LT',CRIT)
LMASK=.TRUE.
! WRITE(6,*) 'ZOR RSLMSK'
! ZNNT=1.
! CALL NNTPRT(RSLMSK,IJMAX,ZNNT)
!
! Albedo
!
! ELSEIF(KPDS5.EQ.KPDALB) THEN
! DO J=1,JMAX
! DO I=1,IMAX
! RSLMSK(I,J)=DATA(I,J)
! ENDDO
! ENDDO
! CRIT=99.
! CALL ROF01(RSLMSK,IJMAX,'LT',CRIT)
! LMASK=.TRUE.
! WRITE(6,*) 'ALB RSLMSK'
! ZNNT=1.
! CALL NNTPRT(RSLMSK,IJMAX,ZNNT)
!
! Albedo
!
!cbosu new snowfree albedo database has bitmap, use it.
ELSEIF(KPDS5.EQ.KPDALB(1)) THEN
if (kpds4 == 192) then ! use the bitmap
rslmsk = 0.
do j = 1, jmax
do i = 1, imax
if (lbms(i,j)) then
rslmsk(i,j) = 1.
end if
enddo
enddo
lmask = .true.
else ! no bitmap. old database has no water flag.
LMASK=.FALSE.
end if
ELSEIF(KPDS5.EQ.KPDALB(2)) THEN
!cbosu
if (kpds4 == 192) then ! use the bitmap
rslmsk = 0.
do j = 1, jmax
do i = 1, imax
if (lbms(i,j)) then
rslmsk(i,j) = 1.
end if
enddo
enddo
lmask = .true.
else ! no bitmap. old database has no water flag.
LMASK=.FALSE.
end if
ELSEIF(KPDS5.EQ.KPDALB(3)) THEN
!cbosu
if (kpds4 == 192) then ! use the bitmap
rslmsk = 0.
do j = 1, jmax
do i = 1, imax
if (lbms(i,j)) then
rslmsk(i,j) = 1.
end if
enddo
enddo
lmask = .true.
else ! no bitmap. old database has no water flag.
LMASK=.FALSE.
end if
ELSEIF(KPDS5.EQ.KPDALB(4)) THEN
!cbosu
if (kpds4 == 192) then ! use the bitmap
rslmsk = 0.
do j = 1, jmax
do i = 1, imax
if (lbms(i,j)) then
rslmsk(i,j) = 1.
end if
enddo
enddo
lmask = .true.
else ! no bitmap. old database has no water flag.
LMASK=.FALSE.
end if
!
! Vegetation fraction for Albedo
!
ELSEIF(KPDS5.EQ.KPDALF(1)) THEN
! RSLMSK=DATA
! CRIT=0.
! CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
! LMASK=.TRUE.
LMASK=.FALSE.
ELSEIF(KPDS5.EQ.KPDALF(2)) THEN
! RSLMSK=DATA
! CRIT=0.
! CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
! LMASK=.TRUE.
LMASK=.FALSE.
!
! Sea ice
!
ELSEIF(KPDS5.EQ.KPDAIS) THEN
LMASK=.FALSE.
! CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
! &, DLON, DLAT, GAUS, BLNO, BLTO)
! CRIT=0.5
! CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
!
data_max = 0.0
do j=1,jmax
do i=1,imax
rslmsk(i,j) = data(i,j)
data_max= max(data_max,data(i,j))
enddo
enddo
CRIT=1.0
if (data_max .gt. CRIT) then
CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
LMASK=.TRUE.
else
LMASK=.FALSE.
endif
! WRITE(6,*) 'ACN RSLMSK'
! ZNNT=1.
! CALL NNTPRT(RSLMSK,IJMAX,ZNNT)
!
! Deep soil temperature
!
ELSEIF(KPDS5.EQ.KPDTG3) THEN
LMASK=.FALSE.
! CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
! &, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
! CRIT=0.5
! CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
! LMASK=.TRUE.
!
! Plant resistance
!
! ELSEIF(KPDS5.EQ.KPDPLR) THEN
! CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
! &, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
! CRIT=0.5
! CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
! LMASK=.TRUE.
!
! WRITE(6,*) 'PLR RSLMSK'
! ZNNT=1.
! CALL NNTPRT(RSLMSK,IJMAX,ZNNT)
!
! Glacier points
!
ELSEIF(KPDS5.EQ.KPDGLA) THEN
LMASK=.FALSE.
!
! Max ice extent
!
ELSEIF(KPDS5.EQ.KPDMXI) THEN
LMASK=.FALSE.
!
! Snow cover
!
ELSEIF(KPDS5.EQ.KPDSCV) THEN
CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
&, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
CRIT=0.5
CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
LMASK=.TRUE.
! WRITE(6,*) 'SCV RSLMSK'
! ZNNT=1.
! CALL NNTPRT(RSLMSK,IJMAX,ZNNT)
!
! Sea ice concentration
!
ELSEIF(KPDS5.EQ.KPDACN) THEN
LMASK=.FALSE.
CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
&, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
CRIT=0.5
CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
LMASK=.TRUE.
! WRITE(6,*) 'ACN RSLMSK'
! ZNNT=1.
! CALL NNTPRT(RSLMSK,IJMAX,ZNNT)
!
! Vegetation cover
!
ELSEIF(KPDS5.EQ.KPDVEG) THEN
!cggg
if (kpds4 == 192) then ! use the bitmap
rslmsk = 0.
do j = 1, jmax
do i = 1, imax
if (lbms(i,j)) then
rslmsk(i,jmax-j+1) = 1. ! need to flip grid in n/s direction
end if
enddo
enddo
lmask = .true.
else ! no bitmap, set mask the old way.
CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
&, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
CRIT=0.5
CALL ROF01(RSLMSK,IJMAX,'GE',CRIT)
LMASK=.TRUE.
end if
!
! Soil type
!
ELSEIF(KPDS5.EQ.KPDSOT) THEN
! CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
! &, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
!cggg soil type is zero over water, use this to get a bitmap.
do j = 1, jmax
do i = 1, imax
rslmsk(i,j) = data(i,j)
enddo
enddo
CRIT=0.1
CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
LMASK=.TRUE.
!
! Vegetation type
!
ELSEIF(KPDS5.EQ.KPDVET) THEN
! CALL GA2LA(SLMASK,IGAUL,JGAUL,RSLMSK,IMAX,JMAX,WLON,RNLAT
! &, RLNOUT, RLTOUT, GAUS, BLNO, BLTO)
! &, DLON, DLAT, GAUS, BLNO, BLTO)
!cggg veg type is zero over water, use this to get a bitmap.
do j = 1, jmax
do i = 1, imax
rslmsk(i,j) = data(i,j)
enddo
enddo
CRIT=0.1
CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
LMASK=.TRUE.
!
! These are for four new data type added by Clu -- not sure its correct!
!
ELSEIF(KPDS5.EQ.KPDVMN) THEN
!
!cggg greenness is zero over water, use this to get a bitmap.
!
do j = 1, jmax
do i = 1, imax
rslmsk(i,j) = data(i,j)
enddo
enddo
!
CRIT=0.1
CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
LMASK=.TRUE.
!cggg LMASK=.FALSE.
!
ELSEIF(KPDS5.EQ.KPDVMX) THEN
!
!cggg greenness is zero over water, use this to get a bitmap.
!
do j = 1, jmax
do i = 1, imax
rslmsk(i,j) = data(i,j)
enddo
enddo
!
CRIT=0.1
CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
LMASK=.TRUE.
!cggg LMASK=.FALSE.
!
ELSEIF(KPDS5.EQ.KPDSLP) THEN
!
!cggg slope type is zero over water, use this to get a bitmap.
!
do j = 1, jmax
do i = 1, imax
rslmsk(i,j) = data(i,j)
enddo
enddo
!
CRIT=0.1
CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
LMASK=.TRUE.
!cggg LMASK=.FALSE.
!
!cbosu new maximum snow albedo database has bitmap
ELSEIF(KPDS5.EQ.KPDABS) THEN
if (kpds4 == 192) then ! use the bitmap
rslmsk = 0.
do j = 1, jmax
do i = 1, imax
if (lbms(i,j)) then
rslmsk(i,j) = 1.
end if
enddo
enddo
lmask = .true.
else ! no bitmap. old database has zero over water
do j = 1, jmax
do i = 1, imax
rslmsk(i,j) = data(i,j)
enddo
enddo
CRIT=0.1
CALL ROF01(RSLMSK,IJMAX,'GT',CRIT)
LMASK=.TRUE.
end if
ENDIF
!
RETURN
END
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,
& j,iret
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)
&, RLNOUT(IMXOUT), RLTOUT(JMXOUT)
LOGICAL GAUS
!
Real, allocatable :: GAUL(:)
REAL (KIND=KIND_IO8) DDX(IMXOUT),DDY(JMXOUT)
Integer IINDX1(IMXOUT), IINDX2(IMXOUT),
& JINDX1(JMXOUT), JINDX2(JMXOUT)
integer JMXSAV,N,KSPLA
data JMXSAV/0/
save jmxsav, gaul, dlati
REAL (KIND=KIND_IO8) radi
REAL (KIND=KIND_IO8) A(jmxin), W(jmxin)
!
!
logical first
integer NUM_THREADS
data first /.true./
save NUM_THREADS, first
!
integer LEN_THREAD_M, J1_T, J2_T, IT
integer NUM_PARTHDS
!
if (first) then
NUM_THREADS = NUM_PARTHDS()
first = .false.
endif
!
if (jmxin .ne. jmxsav) then
if (jmxsav .gt. 0) deallocate (GAUL, STAT=iret)
allocate (GAUL(JMXIN))
jmxsav = JMXIN
IF (GAUS) THEN
cjfe CALL GAULAT(GAUL,JMXIN)
cjfe
!
KSPLA=4
CALL SPLAT(KSPLA, JMXIN, A, W)
!
RADI = 180.0 / (4.*ATAN(1.))
DO N=1,JMXIN
GAUL(N) = ACOS(A(N)) * RADI
ENDDO
cjfe
DO J=1,JMXIN
GAUL(J) = 90. - GAUL(J)
ENDDO
ELSE
DLAT = -2*BLTO / FLOAT(JMXIN-1)
DLATI = 1 / DLAT
DO J=1,JMXIN
GAUL(J) = BLTO + (J-1) * DLAT
ENDDO
ENDIF
ENDIF
!
!
DXIN = 360. / FLOAT(IMXIN )
!
DO I=1,IMXOUT
ALAMD = RLNOUT(I)
I1 = FLOOR((ALAMD-BLNO)/DXIN) + 1
DDX(I) = (ALAMD-BLNO)/DXIN-(I1-1)
IINDX1(I) = MODULO(I1-1,IMXIN) + 1
IINDX2(I) = MODULO(I1 ,IMXIN) + 1
ENDDO
!
!
LEN_THREAD_M = (JMXOUT+NUM_THREADS-1) / NUM_THREADS
!
IF (GAUS) THEN
!
!$OMP PARALLEL DO PRIVATE(J1_T,J2_T,IT,J1,J2,JJ)
!$OMP+PRIVATE(APHI)
!$OMP+SHARED(NUM_THREADS,LEN_THREAD_M)
!$OMP+SHARED(JMXIN,JMXOUT,GAUL,RLTOUT,JINDX1,DDY)
!
DO IT=1,NUM_THREADS ! START OF THREADED LOOP ...................
J1_T = (IT-1)*LEN_THREAD_M+1
J2_T = MIN(J1_T+LEN_THREAD_M-1,JMXOUT)
!
J2=1
DO 40 J=J1_T,J2_T
APHI=RLTOUT(J)
DO 50 JJ=1,JMXIN
IF(APHI.LT.GAUL(JJ)) GO TO 50
J2=JJ
GO TO 42
50 CONTINUE
42 CONTINUE
IF(J2.GT.2) GO TO 43
J1=1
J2=2
GO TO 44
43 CONTINUE
IF(J2.LE.JMXIN) GO TO 45
J1=JMXIN-1
J2=JMXIN
GO TO 44
45 CONTINUE
J1=J2-1
44 CONTINUE
JINDX1(J)=J1
JINDX2(J)=J2
DDY(J)=(APHI-GAUL(J1))/(GAUL(J2)-GAUL(J1))
40 CONTINUE
ENDDO ! END OF THREADED LOOP ...................
!$OMP END PARALLEL DO
!
ELSE
!$OMP PARALLEL DO PRIVATE(J1_T,J2_T,IT,J1,J2,JTEM)
!$OMP+PRIVATE(APHI)
!$OMP+SHARED(NUM_THREADS,LEN_THREAD_M)
!$OMP+SHARED(JMXIN,JMXOUT,GAUL,RLTOUT,JINDX1,DDY,DLATI,BLTO)
!
DO IT=1,NUM_THREADS ! START OF THREADED LOOP ...................
J1_T = (IT-1)*LEN_THREAD_M+1
J2_T = MIN(J1_T+LEN_THREAD_M-1,JMXOUT)
!
J2=1
DO 400 J=J1_T,J2_T
APHI=RLTOUT(J)
JTEM = (APHI - BLTO) * DLATI + 1
IF (JTEM .GE. 1 .AND. JTEM .LT. JMXIN) THEN
J1 = JTEM
J2 = J1 + 1
DDY(J)=(APHI-GAUL(J1))/(GAUL(J2)-GAUL(J1))
ELSEIF (JTEM .EQ. JMXIN) THEN
J1 = JMXIN
J2 = JMXIN
DDY(J)=1.0
ELSE
J1 = 1
J2 = 1
DDY(J)=1.0
ENDIF
!
JINDX1(J) = J1
JINDX2(J) = J2
400 CONTINUE
ENDDO ! END OF THREADED LOOP ...................
!$OMP END PARALLEL DO
ENDIF
!
! WRITE(6,*) 'GA2LA'
! WRITE(6,*) 'IINDX1'
! WRITE(6,*) (IINDX1(N),N=1,IMXOUT)
! WRITE(6,*) 'IINDX2'
! WRITE(6,*) (IINDX2(N),N=1,IMXOUT)
! WRITE(6,*) 'JINDX1'
! WRITE(6,*) (JINDX1(N),N=1,JMXOUT)
! WRITE(6,*) 'JINDX2'
! WRITE(6,*) (JINDX2(N),N=1,JMXOUT)
! WRITE(6,*) 'DDY'
! WRITE(6,*) (DDY(N),N=1,JMXOUT)
! WRITE(6,*) 'DDX'
! WRITE(6,*) (DDX(N),N=1,JMXOUT)
!
!
!$OMP PARALLEL DO PRIVATE(J1_T,J2_T,IT,I,I1,I2)
!$OMP+PRIVATE(J,J1,J2,X,Y)
!$OMP+SHARED(NUM_THREADS,LEN_THREAD_M)
!$OMP+SHARED(IMXOUT,IINDX1,JINDX1,DDX,DDY,GAUIN,REGOUT)
!
DO IT=1,NUM_THREADS ! START OF THREADED LOOP ...................
J1_T = (IT-1)*LEN_THREAD_M+1
J2_T = MIN(J1_T+LEN_THREAD_M-1,JMXOUT)
!
DO J=J1_T,J2_T
Y = DDY(J)
J1 = JINDX1(J)
J2 = JINDX2(J)
DO I=1,IMXOUT
X = DDX(I)
I1 = IINDX1(I)
I2 = IINDX2(I)
REGOUT(I,J) = (1.-X)*((1.-Y)*GAUIN(I1,J1) + Y*GAUIN(I1,J2))
& + X *((1.-Y)*GAUIN(I2,J1) + Y*GAUIN(I2,J2))
ENDDO
ENDDO
ENDDO ! END OF THREADED LOOP ...................
!$OMP END PARALLEL DO
!
SUM1 = 0.
SUM2 = 0.
DO I=1,IMXIN
SUM1 = SUM1 + GAUIN(I,1)
SUM2 = SUM2 + GAUIN(I,JMXIN)
ENDDO
SUM1 = SUM1 / FLOAT(IMXIN)
SUM2 = SUM2 / FLOAT(IMXIN)
!
IF (GAUS) THEN
IF (RNLAT .GT. 0.0) THEN
DO I=1,IMXOUT
REGOUT(I, 1) = SUM1
REGOUT(I,JMXOUT) = SUM2
ENDDO
ELSE
DO I=1,IMXOUT
REGOUT(I, 1) = SUM2
REGOUT(I,JMXOUT) = SUM1
ENDDO
ENDIF
ELSE
IF (BLTO .LT. 0.0) THEN
IF (RNLAT .GT. 0.0) THEN
DO I=1,IMXOUT
REGOUT(I, 1) = SUM2
REGOUT(I,JMXOUT) = SUM1
ENDDO
ELSE
DO I=1,IMXOUT
REGOUT(I, 1) = SUM1
REGOUT(I,JMXOUT) = SUM2
ENDDO
ENDIF
ELSE
IF (RNLAT .LT. 0.0) THEN
DO I=1,IMXOUT
REGOUT(I, 1) = SUM2
REGOUT(I,JMXOUT) = SUM1
ENDDO
ELSE
DO I=1,IMXOUT
REGOUT(I, 1) = SUM1
REGOUT(I,JMXOUT) = SUM2
ENDDO
ENDIF
ENDIF
ENDIF
!
RETURN
END
!Clu [-1L/+1L] add slptype
!Clu subroutine landtyp(vegtype,soiltype,slmask,LEN)
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)
!Clu [+1L] add slptype
+, slptype(LEN)
!
! make sure that the soil type and veg type are non-zero over land
!
do i = 1, LEN
if (slmask(i) .eq. 1) then
if (vegtype(i) .eq. 0.) vegtype(i) = 7
if (soiltype(i) .eq. 0.) soiltype(i) = 2
!Clu [+1L] add slptype
if (slptype(i) .eq. 0.) slptype(i) = 1
endif
enddo
return
end
SUBROUTINE GAULAT(GAUL,K)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer n,k
REAL (KIND=KIND_IO8) radi
REAL (KIND=KIND_IO8) A(K), W(K), GAUL(K)
!
CALL SPLAT(4, K, A, W)
!
RADI = 180.0 / (4.*ATAN(1.))
DO N=1,K
GAUL(N) = ACOS(A(N)) * RADI
ENDDO
!
! PRINT *,'GAUSSIAN LAT (DEG) FOR JMAX=',K
! PRINT *,(GAUL(N),N=1,K)
!
RETURN
70 WRITE(6,6000)
6000 FORMAT(//5X,'ERROR IN GAUAW'//)
STOP
END
!-----------------------------------------------------------------------
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),
& TSFCLM(LEN), TSFCL0(LEN)
!
! Time interpolation of anomalies
! Add initial anomaly to date interpolated climatology
!
WRITE(6,*) 'ANOMINT'
DO I=1,LEN
TSFANL(I) = TSFAN0(I) - TSFCL0(I) + TSFCLM(I)
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,
!Clu [+1L] add fn()c for vmn, vmx, slp, abs
& 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,
!Clu [+1L] add ()clm for vmn, vmx, slp, abs
& VMNCLM,VMXCLM,SLPCLM,ABSCLM,
& KPDTSF,KPDWET,KPDSNO,KPDZOR,KPDALB,KPDAIS,
& KPDTG3,KPDSCV,KPDACN,KPDSMC,KPDSTC,KPDVEG,
& kpdvet,kpdsot,kpdalf,TSFCL0,
!Clu [+1L] add kpd() for vmn, vmx, slp, abs
& KPDVMN,KPDVMX,KPDSLP,KPDABS,
& DELTSFC, LANOM
&, IMSK, JMSK, SLMSKH, OUTLAT, OUTLON
&, GAUS, BLNO, BLTO, me,lprnt,iprnt, FNALBC2, IALB)
!
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
REAL (KIND=KIND_IO8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s,
& wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2
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
!Clu [+1L] add kpd() for vmn, vmx, slp, abs
&, kpdvmn,kpdvmx,kpdslp,kpdabs
INTEGER kpdalb(4), kpdalf(2)
!
!cbosu
CHARACTER*500 FNTSFC,FNWETC,FNSNOC,FNZORC,FNALBC,FNAISC,
& FNTG3C,FNSCVC,FNSMCC,FNSTCC,FNACNC,FNVEGC,
& fnvetc,fnsotc,fnalbc2
!Clu [+1L] add fn()c for vmn, vmx, slp, abs
&, 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)
!Clu [+1L] add ()cm for vmn, vmx, slp, abs
&, VMNCLM(LEN),VMXCLM(LEN),SLPCLM(LEN),ABSCLM(LEN)
REAL (KIND=KIND_IO8) SLMSKH(IMSK,JMSK)
REAL (KIND=KIND_IO8) OUTLAT(LEN), OUTLON(LEN)
!
REAL (KIND=KIND_IO8) SLMASK(LEN), TSFCL0(LEN)
!
LOGICAL LANOM, GAUS, first
!
! DAYHF : JULIAN DAY OF THE MIDDLE OF EACH MONTH
!
REAL (KIND=KIND_IO8) DAYHF(13)
DATA DAYHF/ 15.5, 45.0, 74.5,105.0,135.5,166.0,
& 196.5,227.5,258.0,288.5,319.0,349.5,380.5/
!
real (kind=kind_io8) fha(5)
integer ida(8),jda(8)
!
real (kind=kind_io8), allocatable :: tsf(:,:),sno(:,:),
& zor(:,:),wet(:,:),
& ais(:,:), acn(:,:), scv(:,:), smc(:,:,:),
& tg3(:), alb(:,:,:), alf(:,:),
& vet(:), sot(:), tsf2(:),
& veg(:,:), stc(:,:,:)
!Clu [+1L] add vmn, vmx, slp, abs
&, vmn(:), vmx(:), slp(:), abs(:)
!
integer mon1s, mon2s, sea1s, sea2s, sea1, sea2
data first/.true./
data mon1s/0/, mon2s/0/, sea1s/0/, sea2s/0/
!
save first, tsf, sno, zor, wet, ais, acn, scv, smc, tg3,
& alb, alf, vet, sot, tsf2, veg, stc
!Clu [+1L] add vmn, vmx, slp, abs
&, vmn, vmx, slp, abs,
& mon1s, mon2s, sea1s, sea2s, dayhf, k1, k2, m1, m2
!
logical lprnt
!
DO I=1,LEN
TSFCLM(I) = 0.0
TSFCL2(I) = 0.0
SNOCLM(I) = 0.0
WETCLM(I) = 0.0
ZORCLM(I) = 0.0
AISCLM(I) = 0.0
TG3CLM(I) = 0.0
ACNCLM(I) = 0.0
CVCLM(I) = 0.0
CVBCLM(I) = 0.0
CVTCLM(I) = 0.0
CNPCLM(I) = 0.0
SLICLM(I) = 0.0
SCVCLM(I) = 0.0
!Clu [+4L] add ()clm for vmn, vmx, slp, abs
VMNCLM(I) = 0.0
VMXCLM(I) = 0.0
SLPCLM(I) = 0.0
ABSCLM(I) = 0.0
ENDDO
DO K=1,LSOIL
DO I=1,LEN
SMCCLM(I,K) = 0.0
STCCLM(I,K) = 0.0
ENDDO
ENDDO
DO K=1,4
DO I=1,LEN
ALBCLM(I,K) = 0.0
ENDDO
ENDDO
DO K=1,2
DO I=1,LEN
ALFCLM(I,K) = 0.0
ENDDO
ENDDO
!
IRET = 0
MONEND = 9999
!
if (first) then
!
! Allocate variables to be saved
!
Allocate (tsf(len,2), sno(len,2), zor(len,2),
& wet(len,2), ais(len,2), acn(len,2),
& scv(len,2), smc(len,lsoil,2),
& tg3(len), alb(len,4,2), alf(len,2),
& vet(len), sot(len), tsf2(len),
!Clu [+1L] add vmn, vmx, slp, abs
& vmn(len), vmx(len), slp(len), abs(len),
& veg(len,2), stc(len,lsoil,2))
!
! Get TSF climatology for the begining of the forecast
!
if (fh .gt. 0.0) then
!cbosu
if (me == 0) print*,'bosu fh gt 0'
iy4=iy
if(iy.lt.101) iy4=1900+iy4
fha=0
ida=0
jda=0
! fha(2)=nint(fh)
ida(1)=iy
ida(2)=im
ida(3)=id
ida(5)=ih
call w3movdat(fha,ida,jda)
jy=jda(1)
jm=jda(2)
jd=jda(3)
jh=jda(5)
if (me .eq. 0) write(6,*) ' Forecast JY,JM,JD,JH',
& jy,jm,jd,jh
jdow = 0
jdoy = 0
jday = 0
call w3doxdat(jda,jdow,jdoy,jday)
rjday=jdoy+jda(5)/24.
IF(RJDAY.LT.DAYHF(1)) RJDAY=RJDAY+365.
!
if (me .eq. 0) WRITE(6,*) 'Forecast JY,JM,JD,JH=',JY,JM,JD,JH
!
! For monthly mean climatology
!
MONEND = 12
DO MM=1,MONEND
MMM=MM
MMP=MM+1
IF(RJDAY.GE.DAYHF(MMM).AND.RJDAY.LT.DAYHF(MMP)) THEN
MON1=MMM
MON2=MMP
GO TO 10
ENDIF
ENDDO
PRINT *,'WRONG RJDAY',RJDAY
CALL ABORT
10 CONTINUE
WEI1M = (DAYHF(MON2)-RJDAY)/(DAYHF(MON2)-DAYHF(MON1))
WEI2M = (RJDAY-DAYHF(MON1))/(DAYHF(MON2)-DAYHF(MON1))
IF(MON2.EQ.13) MON2=1
if (me .eq. 0) PRINT *,'RJDAY,MON1,MON2,WEI1M,WEI2M=',
& RJDAY,MON1,MON2,WEI1M,WEI2M
!
! Read Monthly mean climatology of TSF
!
do nn=1,2
MON = MON1
if (NN .eq. 2) MON = MON2
CALL FIXRDC(LUGB,FNTSFC,KPDTSF,MON,SLMASK,
& TSF(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
enddo
!
! TSF AT THE BEGINING OF FORECAST I.E. FH=0
!
DO I=1,LEN
TSFCL0(I) = wei1m * tsf(i,1) + wei2m * tsf(i,2)
ENDDO
endif
endif
!
! Compute current JY,JM,JD,JH of forecast and the day of the year
!
iy4=iy
if(iy.lt.101) iy4=1900+iy4
fha = 0
ida = 0
jda = 0
fha(2) = nint(fh)
ida(1) = iy
ida(2) = im
ida(3) = id
ida(5) = ih
call w3movdat(fha,ida,jda)
jy = jda(1)
jm = jda(2)
jd = jda(3)
jh = jda(5)
! if (me .eq. 0) write(6,*) ' Forecast JY,JM,JD,JH,rjday=',
! & jy,jm,jd,jh,rjday
jdow = 0
jdoy = 0
jday = 0
call w3doxdat(jda,jdow,jdoy,jday)
rjday = jdoy+jda(5)/24.
IF(RJDAY.LT.DAYHF(1)) RJDAY=RJDAY+365.
if (me .eq. 0) write(6,*) ' Forecast JY,JM,JD,JH,rjday=',
& jy,jm,jd,jh,rjday
!
if (me .eq. 0) WRITE(6,*) 'Forecast JY,JM,JD,JH=',JY,JM,JD,JH
!
! For monthly mean climatology
!
MONEND = 12
DO MM=1,MONEND
MMM=MM
MMP=MM+1
IF(RJDAY.GE.DAYHF(MMM).AND.RJDAY.LT.DAYHF(MMP)) THEN
MON1=MMM
MON2=MMP
GO TO 20
ENDIF
ENDDO
PRINT *,'WRONG RJDAY',RJDAY
CALL ABORT
20 CONTINUE
WEI1M=(DAYHF(MON2)-RJDAY)/(DAYHF(MON2)-DAYHF(MON1))
WEI2M=(RJDAY-DAYHF(MON1))/(DAYHF(MON2)-DAYHF(MON1))
IF(MON2.EQ.13) MON2=1
if (me .eq. 0) PRINT *,'RJDAY,MON1,MON2,WEI1M,WEI2M=',
& RJDAY,MON1,MON2,WEI1M,WEI2M
!
! For seasonal mean climatology
!
MONEND = 4
IS = IM/3 + 1
IF (IS.EQ.5) IS = 1
DO MM=1,MONEND
MMM = MM*3 - 2
MMP = (MM+1)*3 - 2
IF(RJDAY.GE.DAYHF(MMM).AND.RJDAY.LT.DAYHF(MMP)) THEN
SEA1 = MMM
SEA2 = MMP
GO TO 30
ENDIF
ENDDO
PRINT *,'WRONG RJDAY',RJDAY
CALL ABORT
30 CONTINUE
WEI1S = (DAYHF(SEA2)-RJDAY)/(DAYHF(SEA2)-DAYHF(SEA1))
WEI2S = (RJDAY-DAYHF(SEA1))/(DAYHF(SEA2)-DAYHF(SEA1))
IF(SEA2.EQ.13) SEA2=1
if (me .eq. 0) PRINT *,'RJDAY,SEA1,SEA2,WEI1S,WEI2S=',
& RJDAY,SEA1,SEA2,WEI1S,WEI2S
!
! START READING IN CLIMATOLOGY AND INTERPOLATE TO THE DATE
!
FIRST_TIME : if (first) then
!cbosu
if (me == 0) print*,'bosu first time thru'
!
! Annual mean climatology
!
! Fraction of vegetation field for albedo -- There are two
! fraction fields in this version: strong zeneith angle dependent
! and weak zeneith angle dependent
!
kpd9 = -1
cjfe
alf=0.
cjfe
if (ialb == 1) then
!cbosu still need facsf and facwf. read them from the production
!cbosu file
!cbosu
CALL FIXRDC(LUGB,FNALBC2,KPDALF(1),kpd9,SLMASK
&, ALF,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
else
CALL FIXRDC(LUGB,FNALBC,KPDALF(1),kpd9,SLMASK
&, ALF,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
endif
do I = 1, LEN
if(slmask(I).eq.1.) then
alf(I,2) = 100. - alf(I,1)
endif
enddo
!
! Deep Soil Temperature
!
IF(FNTG3C(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNTG3C,KPDTG3,kpd9,SLMASK,
& TG3,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ENDIF
!
! Vegetation type
!
IF(FNVEtC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNVEtC,KPDVEt,kpd9,SLMASK,
& VEt,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
if (me .eq. 0) WRITE(6,*) 'Climatological vegetation',
& ' type read in.'
ENDIF
!
! soil type
!
IF(FNsotC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNsotC,KPDsot,kpd9,SLMASK,
& sot,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
if (me .eq. 0) WRITE(6,*) 'Climatological soil type read in.'
ENDIF
!Clu ----------------------------------------------------------------------
!
! Min vegetation cover
!
IF(FNvmnC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNvmnC,KPDvmn,kpd9,SLMASK,
& vmn,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
if (me .eq. 0) WRITE(6,*) 'Climatological shdmin read in.'
ENDIF
!
! Max vegetation cover
!
IF(FNvmxC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNvmxC,KPDvmx,kpd9,SLMASK,
& vmx,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
if (me .eq. 0) WRITE(6,*) 'Climatological shdmax read in.'
ENDIF
!
! Slope type
!
IF(FNslpC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNslpC,KPDslp,kpd9,SLMASK,
& slp,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
if (me .eq. 0) WRITE(6,*) 'Climatological slope read in.'
ENDIF
!
! Max snow albeod
!
IF(FNabsC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNabsC,KPDabs,kpd9,SLMASK,
& abs,LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
if (me .eq. 0) WRITE(6,*) 'Climatological snoalb read in.'
ENDIF
!Clu ----------------------------------------------------------------------
!
IS1 = SEA1/3 + 1
IS2 = SEA2/3 + 1
IF (IS1 .EQ. 5) IS1 = 1
IF (IS2 .EQ. 5) IS2 = 1
DO NN=1,2
!
! Seasonal mean climatology
IF(NN.EQ.1) THEN
ISX=IS1
ELSE
ISX=IS2
ENDIF
IF(ISX.EQ.1) kpd9 = 12
IF(ISX.EQ.2) kpd9 = 3
IF(ISX.EQ.3) kpd9 = 6
IF(ISX.EQ.4) kpd9 = 9
!
! Seasonal mean climatology
!
! ALBEDO
! There are four albedo fields in this version:
! two for strong zeneith angle dependent (visible and near IR)
! and two for weak zeneith angle dependent (VIS ANS NIR)
!
if (ialb == 0) then
DO K = 1, 4
CALL FIXRDC(LUGB,FNALBC,KPDALB(K),kpd9,SLMASK,
& ALB(1,K,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ENDDO
endif
!
! Monthly mean climatology
!
MON = MON1
if (NN .eq. 2) MON = MON2
!cbosu
!cbosu new snowfree albedo database is monthly.
if (ialb == 1) then
print*,'first call to fixrdc for snowfree alb ', first,
& nn, mon
DO K = 1, 4
CALL FIXRDC(LUGB,FNALBC,KPDALB(K),mon,SLMASK,
& ALB(1,K,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ENDDO
endif
! if(lprnt) print *,' mon1=',mon1,' mon2=',mon2
!
! TSF AT THE CURRENT TIME T
!
CALL FIXRDC(LUGB,FNTSFC,KPDTSF,MON,SLMASK,
& TSF(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
! if(lprnt) print *,' tsf=',tsf(iprnt,nn),' nn=',nn
!
! TSF...AT TIME T-DELTSFC
!
! FH2 = FH - DELTSFC
! IF (FH2 .GT. 0.0) THEN
! CALL FIXRD(LUGB,FNTSFC,KPDTSF,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH2,TSFCL2,LEN,IRET
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
! ELSE
! DO I=1,LEN
! TSFCL2(I) = TSFCLM(I)
! ENDDO
! ENDIF
!
! SOIL WETNESS
!
IF(FNWETC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNWETC,KPDWET,MON,SLMASK,
& WET(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ELSEIF(FNSMCC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNSMCC,KPDSMC,MON,SLMASK,
& SMC(1,LSOIL,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
do l=1,lsoil-1
do i = 1, LEN
smc(i,l,NN) = smc(i,LSOIL,NN)
enddo
enddo
!
! CALL FIXRD(LUGB,FNSMCC,KPDSMC,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH,SMCCLM(1,1),LEN,IRET)
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
! CALL FIXRD(LUGB,FNSMCC,KPDSMC,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH,SMCCLM(1,2),LEN,IRET)
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
ELSE
WRITE(6,*) 'Climatological Soil wetness file not given'
CALL ABORT
ENDIF
!
! SOIL TEMPERATURE
!
IF(FNSTCC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNSTCC,KPDSTC,MON,SLMASK,
& STC(1,LSOIL,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
do l=1,lsoil-1
do i = 1, LEN
stc(i,l,NN) = stc(i,LSOIL,NN)
enddo
enddo
ENDIF
!
! SEA ICE
!
IF(FNACNC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNACNC,KPDACN,MON,SLMASK,
& ACN(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ELSEIF(FNAISC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNAISC,KPDAIS,MON,SLMASK,
& AIS(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ELSE
WRITE(6,*) 'Climatological ice cover file not given'
CALL ABORT
ENDIF
!
! SNOW DEPTH
!
CALL FIXRDC(LUGB,FNSNOC,KPDSNO,MON,SLMASK,
& SNO(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
!
! SNOW COVER
!
IF(FNSCVC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNSCVC,KPDSCV,MON,SLMASK,
& SCV(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
WRITE(6,*) 'Climatological snow cover read in.'
ENDIF
!
! SURFACE ROUGHNESS
!
CALL FIXRDC(LUGB,FNZORC,KPDZOR,MON,SLMASK,
& ZOR(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
!
! MINIMUM STOMATAL RESISTANCE
!
! CALL FIXRD(LUGB,FNPLRC,KPDPLR,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH,PLRCLM,LEN,IRET
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
!
!
DO I = 1, LEN
! Set clouds climatology to zero
CVCLM (I) = 0.
CVBCLM(I) = 0.
CVTCLM(I) = 0.
!
CNPCLM(I) = 0. !Set canopy water content climatology to zero
ENDDO
!
! Layer Soil temperature
!
! ELSEIF(FNSTCC(1:8).NE.' ') THEN
! CALL FIXRD(LUGB,FNSTCC,KPDSTC,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH,STCCLM(1,1),LEN,IRET
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
! CALL FIXRD(LUGB,FNSTCC,KPDSTC,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH,STCCLM(1,2),LEN,IRET
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
! ELSE
! WRITE(6,*) 'Climatological Soil temp file not given'
! CALL ABORT
! ENDIF
!
! Vegetation cover
!
IF(FNVEGC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNVEGC,KPDVEG,MON,SLMASK,
& VEG(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
if (me .eq. 0) WRITE(6,*) 'Climatological vegetation',
& ' cover read in for mon=',mon
ENDIF
! write(0,*) ' endding veg cover read'
!
! IF (LANOM) THEN ! TSF at forecast hour=0.
! CALL FIXRD(LUGB,FNTSFC,KPDTSF,LCLIM,SLMASK,
! & IY,IM,ID,IH,0.,TSFCL0,LEN,IRET
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
! ENDIF
ENDDO
!
mon1s = mon1 ; mon2s = mon2 ; sea1s = sea1 ; sea2s = sea2
!
if (me .eq. 0) print *,' mon1s=',mon1s,' mon2s=',mon2s
&,' sea1s=',sea1s,' sea2s=',sea2s
!
k1 = 1 ; k2 = 2
m1 = 1 ; m2 = 2
!
first = .false.
endif FIRST_TIME
!
! To get TSF climatology at the previous call to SFCCYCLE
!
rjdayh = rjday - deltsfc/24.0
! if(lprnt) print *,' rjdayh=',rjdayh,' mon1=',mon1,' mon2='
! &,mon2,' mon1s=',mon1s,' mon2s=',mon2s,' k1=',k1,' k2=',k2
if (rjdayh .ge. DAYHF(mon1)) then
if (mon2 .eq. 1) mon2 = 13
WEI1X = (DAYHF(mon2)-rjdayh)/(DAYHF(mon2)-DAYHF(mon1))
WEI2X = 1.0 - WEI1X
if (mon2 .eq. 13) mon2 = 1
else
rjdayh2 = rjdayh
IF (RJDAYh .LT. DAYHF(1)) RJDAYh2 = RJDAYh2 + 365.0
if (mon1s .eq. mon1) then
mon1s = mon1 - 1
if (mon1s .eq. 0) mon1s = 12
k2 = k1
k1 = mod(k2,2) + 1
MON = mon1s
CALL FIXRDC(LUGB,FNTSFC,KPDTSF,MON,SLMASK,
& TSF(1,k1),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
endif
mon2s = mon1s + 1
! if (mon2s .eq. 1) mon2s = 13
WEI1X = (DAYHF(mon2s)-rjdayh2)/(DAYHF(mon2s)-DAYHF(mon1s))
WEI2X = 1.0 - WEI1X
if (mon2s .eq. 13) mon2s = 1
do i=1,len
tsf2(I) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2)
enddo
endif
!
!cbosu new albedo is monthly
if (sea1 .ne. sea1s) then
sea1s = sea1
sea2s = sea2
m1 = mod(m1,2) + 1
m2 = mod(m1,2) + 1
!
! Seasonal mean climatology
!
ISX = SEA2/3 + 1
IF (ISX .EQ. 5) ISX = 1
IF(ISX.EQ.1) kpd9 = 12
IF(ISX.EQ.2) kpd9 = 3
IF(ISX.EQ.3) kpd9 = 6
IF(ISX.EQ.4) kpd9 = 9
!
! ALBEDO
! There are four albedo fields in this version:
! two for strong zeneith angle dependent (visible and near IR)
! and two for weak zeneith angle dependent (VIS ANS NIR)
!
!cbosu
if (ialb == 0) then
DO K = 1, 4
CALL FIXRDC(LUGB,FNALBC,KPDALB(K),kpd9,SLMASK
&, ALB(1,K,m2),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ENDDO
endif
endif
if (mon1 .ne. mon1s) then
mon1s = mon1
mon2s = mon2
k1 = mod(k1,2) + 1
k2 = mod(k1,2) + 1
!
! Monthly mean climatology
!
MON = MON2
NN = k2
!cbosu
if (ialb == 1) then
if (me == 0) print*,'bosu 2nd time in clima for month ',
& mon, k1,k2
DO K = 1, 4
CALL FIXRDC(LUGB,FNALBC,KPDALB(K),MON,SLMASK,
& ALB(1,K,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ENDDO
endif
!
! TSF AT THE CURRENT TIME T
!
CALL FIXRDC(LUGB,FNTSFC,KPDTSF,MON,SLMASK,
& TSF(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
!
! SOIL WETNESS
!
IF(FNWETC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNWETC,KPDWET,MON,SLMASK,
& WET(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ELSEIF(FNSMCC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNSMCC,KPDSMC,MON,SLMASK,
& SMC(1,LSOIL,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
do l=1,lsoil-1
do i = 1, LEN
smc(i,l,NN) = smc(i,LSOIL,NN)
enddo
enddo
!
! CALL FIXRD(LUGB,FNSMCC,KPDSMC,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH,SMCCLM(1,1),LEN,IRET)
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
! CALL FIXRD(LUGB,FNSMCC,KPDSMC,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH,SMCCLM(1,2),LEN,IRET)
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
ELSE
WRITE(6,*) 'Climatological Soil wetness file not given'
CALL ABORT
ENDIF
!
! SEA ICE
!
IF(FNACNC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNACNC,KPDACN,MON,SLMASK,
& ACN(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ELSEIF(FNAISC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNAISC,KPDAIS,MON,SLMASK,
& AIS(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
ELSE
WRITE(6,*) 'Climatological ice cover file not given'
CALL ABORT
ENDIF
!
! SNOW DEPTH
!
CALL FIXRDC(LUGB,FNSNOC,KPDSNO,MON,SLMASK,
& SNO(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
!
! SNOW COVER
!
IF(FNSCVC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNSCVC,KPDSCV,MON,SLMASK,
& SCV(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
WRITE(6,*) 'Climatological snow cover read in.'
ENDIF
!
! SURFACE ROUGHNESS
!
CALL FIXRDC(LUGB,FNZORC,KPDZOR,MON,SLMASK,
& ZOR(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
!
! Vegetation cover
!
IF(FNVEGC(1:8).NE.' ') THEN
CALL FIXRDC(LUGB,FNVEGC,KPDVEG,MON,SLMASK,
& VEG(1,NN),LEN,IRET
&, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
&, OUTLAT, OUTLON, me)
! if (me .eq. 0) WRITE(6,*) 'Climatological vegetation',
! & ' cover read in for mon=',mon
ENDIF
!
! MINIMUM STOMATAL RESISTANCE
!
! CALL FIXRD(LUGB,FNPLRC,KPDPLR,LCLIM,SLMASK,
! & IY,IM,ID,IH,FH,PLRCLM,LEN,IRET
! &, IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
! &, OUTLAT, OUTLON, me)
!
endif
!
! Now perform the time interpolation
!
DO I=1,LEN
TSFCLM(I) = wei1m * tsf(i,k1) + wei2m * tsf(i,k2)
SNOCLM(I) = wei1m * sno(i,k1) + wei2m * sno(i,k2)
ZORCLM(I) = wei1m * zor(i,k1) + wei2m * zor(i,k2)
CVCLM(I) = 0.0
CVBCLM(I) = 0.0
CVTCLM(I) = 0.0
CNPCLM(I) = 0.0
tsfcl2(I) = tsf2(i)
ENDDO
! if(lprnt) print *,' tsfclm=',tsfclm(iprnt),' wei1m=',wei1m
! &,' wei2m=',wei2m,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2)
!
if (fh .eq. 0.0) then
do i=1,len
TSFCL0(i) = tsfclm(i)
enddo
endif
if (rjdayh .ge. DAYHF(mon1)) then
do i=1,len
tsf2(I) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2)
tsfcl2(I) = tsf2(i)
enddo
endif
! if(lprnt) print *,' tsf2=',tsf2(iprnt),' wei1x=',wei1x
! &,' wei2x=',wei2x,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2)
! &,' mon1s=',mon1s,' mon2s=',mon2s
! &,' slmask=',slmask(iprnt)
!
IF(FNACNC(1:8).NE.' ') THEN
DO I=1,LEN
ACNCLM(I) = wei1m * acn(i,k1) + wei2m * acn(i,k2)
ENDDO
ELSEIF(FNAISC(1:8).NE.' ') THEN
DO I=1,LEN
AISCLM(I) = wei1m * ais(i,k1) + wei2m * ais(i,k2)
ENDDO
endif
!
IF(FNWETC(1:8).NE.' ') THEN
DO I=1,LEN
WETCLM(I) = wei1m * wet(i,k1) + wei2m * wet(i,k2)
ENDDO
ELSEIF(FNSMCC(1:8).NE.' ') THEN
DO K=1,LSOIL
DO I=1,LEN
SMCCLM(I,K) = wei1m * smc(i,k,k1) + wei2m * smc(i,k,k2)
ENDDO
ENDDO
endif
!
IF(FNSCVC(1:8).NE.' ') THEN
DO I=1,LEN
SCVCLM(I) = wei1m * scv(i,k1) + wei2m * scv(i,k2)
ENDDO
endif
!
IF(FNTG3C(1:8).NE.' ') THEN
DO I=1,LEN
TG3CLM(I) = TG3(i)
ENDDO
ELSEIF(FNSTCC(1:8).NE.' ') THEN
DO K=1,LSOIL
DO I=1,LEN
STCCLM(I,K) = wei1m * stc(i,k,k1) + wei2m * stc(i,k,k2)
ENDDO
ENDDO
endif
!
IF(FNVEGC(1:8).NE.' ') THEN
DO I=1,LEN
VEGCLM(I) = wei1m * veg(i,k1) + wei2m * veg(i,k2)
ENDDO
endif
!
IF(FNVEtC(1:8).NE.' ') THEN
DO I=1,LEN
VETCLM(I) = vet(i)
ENDDO
endif
!
IF(FNsotC(1:8).NE.' ') THEN
DO I=1,LEN
SOTCLM(I) = sot(i)
ENDDO
endif
!Clu ----------------------------------------------------------------------
!
IF(FNvmnC(1:8).NE.' ') THEN
DO I=1,LEN
VMNCLM(I) = vmn(i)
ENDDO
endif
!
IF(FNvmxC(1:8).NE.' ') THEN
DO I=1,LEN
VMXCLM(I) = vmx(i)
ENDDO
endif
!
IF(FNslpC(1:8).NE.' ') THEN
DO I=1,LEN
SLPCLM(I) = slp(i)
ENDDO
endif
!
IF(FNabsC(1:8).NE.' ') THEN
DO I=1,LEN
ABSCLM(I) = abs(i)
ENDDO
endif
!Clu ----------------------------------------------------------------------
!
!cbosu diagnostic print
if (me == 0) print*,'monthly albedo weights are ',
& wei1m,' for k', k1, wei2m, ' for k', k2
if (ialb == 1) then
DO K=1,4
DO I=1,LEN
ALBCLM(I,K) = wei1m * alb(i,k,k1) + wei2m * alb(i,k,k2)
ENDDO
ENDDO
else
DO K=1,4
DO I=1,LEN
ALBCLM(I,K) = wei1s * alb(i,k,m1) + wei2s * alb(i,k,m2)
ENDDO
ENDDO
endif
!
DO K=1,2
DO I=1,LEN
ALFCLM(I,K) = alf(i,k)
ENDDO
ENDDO
!
! END OF CLIMATOLOGY READS
!
RETURN
END
SUBROUTINE FIXRDC(LUGB,FNGRIB,KPDS5,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
&, jj
REAL (KIND=KIND_IO8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto
!
! Read in GRIB climatology files and interpolate to the input
! grid. GRIB files should allow all the necessary parameters
! to be extracted from the description records.
!
!
CHARACTER*500 FNGRIB
! CHARACTER*80 FNGRIB, ASGNSTR
!
REAL (KIND=KIND_IO8) SLMSKH(IMSK,JMSK)
!
REAL (KIND=KIND_IO8) GDATA(LEN), SLMASK(LEN)
REAL (KIND=KIND_IO8), allocatable :: DATA(:,:), RSLMSK(:,:)
real(kind=kind_io8) data4(mdata)
real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:)
!
LOGICAL LMASK, YR2KC, GAUS, IJORDR
LOGICAL*1 LBMS(mdata)
!
INTEGER KPDS(1000),KGDS(1000)
INTEGER JPDS(1000),JGDS(1000), KPDS0(1000)
real (kind=kind_io8) outlat(len), outlon(len)
!
! integer imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv
! date imax_sv/0/, jmax_sv/0/, wlon_sv/999.0/, rnlat_sv/999.0/
! &, kpds1_sv/-1/
! save imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv
! &, rlngrb, rltgrb
!
IRET = 0
!
if (me .eq. 0) WRITE(6,*) ' IN FIXRDC for MON=',MON
&,' FNGRIB=',trim(FNGRIB)
!
CLOSE(LUGB)
call baopenr(lugb,fngrib,iret)
IF (IRET .NE. 0) THEN
WRITE(6,*) ' ERROR IN OPENING FILE ',trim(FNGRIB)
PRINT *,'ERROR IN OPENING FILE ',trim(FNGRIB)
CALL ABORT
ENDIF
if (me .eq. 0) WRITE(6,*) ' FILE ',trim(FNGRIB),
& ' opened. Unit=',LUGB
!
lugi = 0
!
lskip = -1
JPDS = -1
JGDS = -1
JPDS(5) = KPDS5
kpds = jpds
call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata,
& lskip,kpds,kgds,iret)
if (me .eq. 0) then
WRITE(6,*) ' First grib record.'
WRITE(6,*) ' KPDS( 1-10)=',(KPDS(J),J= 1,10)
WRITE(6,*) ' KPDS(11-20)=',(KPDS(J),J=11,20)
WRITE(6,*) ' KPDS(21- )=',(KPDS(J),J=21,22)
endif
yr2kc = (kpds(8) / 100) .gt. 0
KPDS0 = JPDS
KPDS0(4) = -1
KPDS0(18) = -1
IF(IRET.NE.0) THEN
WRITE(6,*) ' Error in GETGBH. IRET: ', iret
IF (IRET==99) WRITE(6,*) ' Field not found.'
CALL ABORT
ENDIF
!
! Handling climatology file
!
lskip = -1
N = 0
JPDS = KPDS0
JPDS(9) = MON
IF(JPDS(9).EQ.13) JPDS(9) = 1
call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip,
& kpds,kgds,lbms,data4,jret)
if (me .eq. 0) WRITE(6,*) ' Input grib file dates=',
& (KPDS(I),I=8,11)
if(jret.eq.0) then
IF(NDATA.EQ.0) THEN
WRITE(6,*) ' Error in getgb'
WRITE(6,*) ' KPDS=',KPDS
WRITE(6,*) ' KGDS=',KGDS
CALL ABORT
ENDIF
IMAX=KGDS(2)
JMAX=KGDS(3)
IJMAX=IMAX*JMAX
allocate (data(imax,jmax))
do j=1,jmax
jj = (j-1)*imax
do i=1,imax
data(i,j) = data4(jj+i)
enddo
enddo
if (me .eq. 0) WRITE(6,*) 'IMAX,JMAX,IJMAX=',IMAX,JMAX,IJMAX
ELSE
WRITE(6,*) ' Error in getgb - jret=', jret
CALL ABORT
ENDIF
!
if (me .eq. 0) then
WRITE(6,*) ' MAXMIN of input as is'
KMAMI=1
CALL MAXMIN(DATA(1,1),IJMAX,KMAMI)
endif
!
CALL GETAREA(KGDS,DLAT,DLON,RSLAT,RNLAT,WLON,ELON,IJORDR,me)
if (me .eq. 0) then
WRITE(6,*) 'IMAX,JMAX,IJMAX,DLON,DLAT,IJORDR,WLON,RNLAT='
WRITE(6,*) IMAX,JMAX,IJMAX,DLON,DLAT,IJORDR,WLON,RNLAT
endif
CALL SUBST(DATA,IMAX,JMAX,DLON,DLAT,IJORDR)
!
! First get SLMASK over input grid
!
allocate (rlngrb(imax), rltgrb(jmax))
allocate (rslmsk(imax,jmax))
CALL SETRMSK(KPDS5,SLMSKH,IMSK,JMSK,WLON,RNLAT,
& DATA,IMAX,JMAX,RLNGRB,RLTGRB,LMASK,RSLMSK
! & DATA,IMAX,JMAX,ABS(DLON),ABS(DLAT),LMASK,RSLMSK
!cggg
&, GAUS,BLNO, BLTO, kgds(1), kpds(4), lbms)
! WRITE(6,*) ' KPDS5=',KPDS5,' LMASK=',LMASK
!
INTTYP = 0
IF(KPDS5.EQ.225) INTTYP = 1
IF(KPDS5.EQ.230) INTTYP = 1
!Clu [+1L] add slope (=236)
IF(KPDS5.EQ.236) INTTYP = 1
if (me .eq. 0) then
if(inttyp.eq.1) print *, ' Nearest grid point used'
&, ' kpds5=',kpds5, ' lmask = ',lmask
endif
!
CALL LA2GA(DATA,IMAX,JMAX,RLNGRB,RLTGRB,WLON,RNLAT,INTTYP,
& GDATA,LEN,LMASK,RSLMSK,SLMASK
&, OUTLAT, OUTLON,me)
!
deallocate (rlngrb, STAT=iret)
deallocate (rltgrb, STAT=iret)
deallocate (data, STAT=iret)
deallocate (rslmsk, STAT=iret)
call baclose(lugb,iret)
!
RETURN
END
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
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
! dates and the grid. GRIB files should allow all the necessary parameters
! to be extracted from the description records.
!
! NREPMX: Max number of days for going back date search
! NVALID: Analysis later than (Current date - NVALID) is regarded as
! valid for current analysis
!
PARAMETER(NREPMX=15, NVALID=4)
!
CHARACTER*500 FNGRIB
! CHARACTER*80 FNGRIB, ASGNSTR
!
REAL (KIND=KIND_IO8) SLMSKH(IMSK,JMSK)
!
REAL (KIND=KIND_IO8) GDATA(LEN), SLMASK(LEN)
REAL (KIND=KIND_IO8), allocatable :: DATA(:,:),RSLMSK(:,:)
real(kind=kind_io8) data4(mdata)
real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:)
!
LOGICAL LMASK, YR2KC, GAUS, IJORDR
LOGICAL*1 LBMS(mdata)
!
INTEGER KPDS(1000),KGDS(1000)
INTEGER JPDS(1000),JGDS(1000), KPDS0(1000)
real (kind=kind_io8) outlat(len), outlon(len)
!
! DAYHF : JULIAN DAY OF THE MIDDLE OF EACH MONTH
!
REAL (KIND=KIND_IO8) DAYHF(13)
DATA DAYHF/ 15.5, 45.0, 74.5,105.0,135.5,166.0,
& 196.5,227.5,258.0,288.5,319.0,349.5,380.5/
!
! MJDAY : NUMBER OF DAYS IN A MONTH
!
INTEGER MJDAY(12)
DATA MJDAY/31,28,31,30,31,30,31,31,30,31,30,31/
!
real (kind=kind_io8) fha(5)
integer ida(8),jda(8)
!
IRET = 0
MONEND = 9999
!
! Compute JY,JM,JD,JH of forecast and the day of the year
!
iy4=iy
if(iy.lt.101) iy4=1900+iy4
fha=0
ida=0
jda=0
fha(2)=nint(fh)
ida(1)=iy
ida(2)=im
ida(3)=id
ida(5)=ih
call w3movdat(fha,ida,jda)
jy=jda(1)
jm=jda(2)
jd=jda(3)
jh=jda(5)
! if (me .eq. 0) write(6,*) ' Forecast JY,JM,JD,JH,rjday=',
! & jy,jm,jd,jh,rjday
jdow = 0
jdoy = 0
jday = 0
call w3doxdat(jda,jdow,jdoy,jday)
rjday=jdoy+jda(5)/24.
IF(RJDAY.LT.DAYHF(1)) RJDAY=RJDAY+365.
if (me .eq. 0) write(6,*) ' Forecast JY,JM,JD,JH,rjday=',
& jy,jm,jd,jh,rjday
!
if (me .eq. 0) then
WRITE(6,*) 'Forecast JY,JM,JD,JH=',JY,JM,JD,JH
!
WRITE(6,*) ' '
WRITE(6,*) '************************************************'
endif
!
CLOSE(LUGB)
call baopenr(lugb,fngrib,iret)
IF (IRET .NE. 0) THEN
WRITE(6,*) ' ERROR IN OPENING FILE ',trim(FNGRIB)
PRINT *,'ERROR IN OPENING FILE ',trim(FNGRIB)
CALL ABORT
ENDIF
if (me .eq. 0) WRITE(6,*) ' FILE ',trim(FNGRIB),
& ' opened. Unit=',LUGB
!
lugi = 0
!
lskip=-1
JPDS=-1
JGDS=-1
JPDS(5)=KPDS5
kpds = jpds
call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata,
& lskip,kpds,kgds,iret)
if (me .eq. 0) then
WRITE(6,*) ' First grib record.'
WRITE(6,*) ' KPDS( 1-10)=',(KPDS(J),J= 1,10)
WRITE(6,*) ' KPDS(11-20)=',(KPDS(J),J=11,20)
WRITE(6,*) ' KPDS(21- )=',(KPDS(J),J=21,22)
endif
yr2kc = (kpds(8) / 100) .gt. 0
KPDS0=JPDS
KPDS0(4)=-1
KPDS0(18)=-1
IF(IRET.NE.0) THEN
WRITE(6,*) ' Error in GETGBH. IRET: ', iret
IF(IRET==99) WRITE(6,*) ' Field not found.'
CALL ABORT
ENDIF
!
! Handling analysis file
!
! Find record for the given hour/day/month/year
!
NREPT=0
JPDS=KPDS0
lskip = -1
IYR=JY
if(iyr.le.100) iyr=2050-mod(2050-iyr,100)
IMO=JM
IDY=JD
IHR=JH
! Year 2000 compatible data
if (yr2kc) then
jpds(8) = iyr
else
jpds(8) = mod(iyr,1900)
endif
50 CONTINUE
JPDS( 8)=MOD(IYR-1,100)+1
JPDS( 9)=IMO
JPDS(10)=IDY
! JPDS(11)=IHR
JPDS(21)=(IYR-1)/100+1
call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip,
& kpds,kgds,lbms,data4,jret)
if (me .eq. 0) WRITE(6,*) ' Input grib file dates=',
& (KPDS(I),I=8,11)
IF(jret.eq.0) THEN
IF(NDATA.EQ.0) THEN
WRITE(6,*) ' Error in getgb'
WRITE(6,*) ' KPDS=',KPDS
WRITE(6,*) ' KGDS=',KGDS
CALL ABORT
ENDIF
IMAX=KGDS(2)
JMAX=KGDS(3)
IJMAX=IMAX*JMAX
allocate (data(imax,jmax))
do j=1,jmax
jj = (j-1)*imax
do i=1,imax
data(i,j) = data4(jj+i)
enddo
enddo
ELSE
IF(NREPT.EQ.0) THEN
if (me .eq. 0) then
WRITE(6,*) ' No matching dates found. Start searching',
& ' nearest matching dates (going back).'
endif
ENDIF
!
! No matching IH found. Search nearest hour
!
IF(IHR.EQ.6) THEN
IHR=0
GO TO 50
ELSEIF(IHR.EQ.12) THEN
IHR=0
GO TO 50
ELSEIF(IHR.EQ.18) THEN
IHR=12
GO TO 50
ELSEIF(IHR.EQ.0.OR.IHR.EQ.-1) THEN
IDY=IDY-1
IF(IDY.EQ.0) THEN
IMO=IMO-1
IF(IMO.EQ.0) THEN
IYR=IYR-1
IF(IYR.LT.0) IYR=99
IMO=12
ENDIF
IDY=31
IF(IMO.EQ.4.OR.IMO.EQ.6.OR.IMO.EQ.9.OR.IMO.EQ.11) IDY=30
IF(IMO.EQ.2) THEN
IF(MOD(IYR,4).EQ.0) THEN
IDY=29
ELSE
IDY=28
ENDIF
ENDIF
ENDIF
IHR=-1
if (me .eq. 0) WRITE(6,*) ' Decremented dates=',
& IYR,IMO,IDY,IHR
NREPT=NREPT+1
IF(NREPT.GT.NVALID) IRET=-1
IF(NREPT.GT.NREPMX) THEN
if (me .eq. 0) then
WRITE(6,*) ' <WARNING:CYCL> Searching range exceeded.'
&, ' May be WRONG grib file given'
WRITE(6,*) ' <WARNING:CYCL> FNGRIB=',trim(FNGRIB)
WRITE(6,*) ' <WARNING:CYCL> Terminating search and',
& ' and setting gdata to -999'
WRITE(6,*) ' Range max=',NREPMX
endif
! IMAX=KGDS(2)
! JMAX=KGDS(3)
! IJMAX=IMAX*JMAX
! DO IJ=1,IJMAX
! DATA(IJ)=0.
! ENDDO
GO TO 100
ENDIF
GO TO 50
ELSE
if (me .eq. 0) then
WRITE(6,*) ' Search of analysis for IHR=',IHR,' failed.'
WRITE(6,*) ' KPDS=',KPDS
WRITE(6,*) ' IYR,IMO,IDY,IHR=',IYR,IMO,IDY,IHR
endif
GO TO 100
ENDIF
ENDIF
!
80 CONTINUE
if (me .eq. 0) then
WRITE(6,*) ' MAXMIN of input as is'
KMAMI=1
CALL MAXMIN(DATA(1,1),IJMAX,KMAMI)
endif
!
CALL GETAREA(KGDS,DLAT,DLON,RSLAT,RNLAT,WLON,ELON,IJORDR,me)
if (me .eq. 0) then
WRITE(6,*) 'IMAX,JMAX,IJMAX,DLON,DLAT,IJORDR,WLON,RNLAT='
WRITE(6,*) IMAX,JMAX,IJMAX,DLON,DLAT,IJORDR,WLON,RNLAT
endif
CALL SUBST(DATA,IMAX,JMAX,DLON,DLAT,IJORDR)
!
! First get SLMASK over input grid
!
allocate (rlngrb(imax), rltgrb(jmax))
allocate (rslmsk(imax,jmax))
CALL SETRMSK(KPDS5,SLMSKH,IMSK,JMSK,WLON,RNLAT,
& DATA,IMAX,JMAX,RLNGRB,RLTGRB,LMASK,RSLMSK
! & DATA,IMAX,JMAX,ABS(DLON),ABS(DLAT),LMASK,RSLMSK
!cggg &, GAUS,BLNO, BLTO, kgds(1))
&, GAUS,BLNO, BLTO, kgds(1), kpds(4), lbms)
! WRITE(6,*) ' KPDS5=',KPDS5,' LMASK=',LMASK
!
INTTYP = 0
IF(KPDS5.EQ.225) INTTYP = 1
IF(KPDS5.EQ.230) INTTYP = 1
IF(KPDS5.EQ.66) INTTYP = 1
if(inttyp.eq.1) print *, ' Nearest grid point used'
!
CALL LA2GA(DATA,IMAX,JMAX,RLNGRB,RLTGRB,WLON,RNLAT,INTTYP,
& GDATA,LEN,LMASK,RSLMSK,SLMASK
&, OUTLAT, OUTLON, me)
!
deallocate (rlngrb, STAT=iret)
deallocate (rltgrb, STAT=iret)
deallocate (data, STAT=iret)
deallocate (rslmsk, STAT=iret)
call baclose(lugb,iret2)
! WRITE(6,*) ' '
RETURN
!
100 CONTINUE
IRET=1
DO I=1,LEN
GDATA(I) = -999.
ENDDO
!
call baclose(lugb,iret2)
!
RETURN
END SUBROUTINE FIXRDA
SUBROUTINE SNODPTH2(GLACIR,SNWMAX,SNOANL, LEN, me)
USE MACHINE , ONLY : kind_io8,kind_io4
implicit none
integer i,me,len
REAL (KIND=KIND_IO8) snwmax
!
REAL (KIND=KIND_IO8) SNOANL(LEN), GLACIR(LEN)
!
if (me .eq. 0) WRITE(6,*) 'SNODPTH2'
!
DO I=1,LEN
!
! IF GLACIAL POINTS HAS SNOW IN CLIMATOLOGY, SET SNO TO SNOMAX
!
IF(GLACIR(I).NE.0..AND.SNOANL(I).LT.SNWMAX*0.5) THEN
SNOANL(I) = SNWMAX + SNOANL(I)
ENDIF
!
ENDDO
RETURN
END