File: C:\NOAA\NEMS_11731\src\atmos\phys\sfcsub.f

1           module sfccyc_module
2           implicit none
3           SAVE
4     !
5     !  GRIB code for each parameter - Used in subroutines SFCCYCLE and SETRMSK.
6     !
7           INTEGER kpdtsf,kpdwet,kpdsno,kpdzor,kpdais,kpdtg3,kpdplr,kpdgla,
8          &        kpdmxi,kpdscv,kpdsmc,kpdoro,kpdmsk,kpdstc,kpdacn,kpdveg,
9          &        kpdvet,kpdsot
10     !Clu [+1L] add kpd() for vmn, vmx, slp, abs
11          &,       kpdvmn,kpdvmx,kpdslp,kpdabs
12     !cggg snow mods start  add snow depth
13          &,       kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4)
14     !cggg snow mods end
15           PARAMETER(KPDTSF=11,  KPDWET=86, KPDSNO=65,  KPDZOR=83,
16     !    1          KPDALB=84,  KPDAIS=91, KPDTG3=11,  KPDPLR=224,
17          1          KPDAIS=91,  KPDTG3=11, KPDPLR=224,
18          2          KPDGLA=238, KPDMXI=91, KPDSCV=238, KPDSMC=144,
19          3          KPDORO=8,   KPDMSK=81, KPDSTC=11,  KPDACN=91, KPDVEG=87,
20     !Clu [+1L] add kpd() for vmn, vmx, slp, abs
21     !cbosu  max snow albedo uses a grib id number of 159, not 255.
22          &          kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255,    
23          &          kpdvet=225, kpdsot=230,kpdabs_1=159,
24     !cggg snow mods start
25          &          kpdsnd=66 )
26     !cggg snow mods end
27     !
28           integer, parameter :: kpdalb_0(4)=(/212,215,213,216/)
29           integer, parameter :: kpdalb_1(4)=(/189,190,191,192/)
30           integer, parameter :: kpdalf(2)=(/214,217/)
31     !
32           end module sfccyc_module
33           SUBROUTINE SFCCYCLE(LUGB,LEN,LSOIL,SIG1T,DELTSFC
34          &,                   IY,IM,ID,IH,FH
35          &,                   RLA, RLO, SLMASK,OROG
36     !Cwu [+1L] add SIHFCS and SICFCS
37          &,                   SIHFCS,SICFCS,SITFCS                 
38     !Clu [+2L] add SWD, SLC, VMN, VMX, SLP, ABS
39          &,                   SWDFCS,SLCFCS      
40          &,                   VMNFCS,VMXFCS,SLPFCS,ABSFCS
41          &,                   TSFFCS,SNOFCS,ZORFCS,ALBFCS,TG3FCS
42          &,                   CNPFCS,SMCFCS,STCFCS,SLIFCS,AISFCS,F10M
43          &,                   VEGFCS,VETFCS,SOTFCS,ALFFCS
44          &,                   CVFCS,CVBFCS,CVTFCS,me,NLUNIT,IALB)
45     !
46           USE MACHINE , ONLY : kind_io8,kind_io4
47           USE sfccyc_module
48           implicit none
49           real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse,
50          &                     orolmx,orolmn,oroomx,oroomn,orosmx,
51          &                     orosmn,oroimx,oroimn,orojmx,orojmn,
52          &                     alblmx,alblmn,albomx,albomn,albsmx,
53          &                     albsmn,albimx,albimn,albjmx,albjmn,
54          &                     wetlmx,wetlmn,wetomx,wetomn,wetsmx,
55          &                     wetsmn,wetimx,wetimn,wetjmx,wetjmn,
56          &                     snolmx,snolmn,snoomx,snoomn,snosmx,
57          &                     snosmn,snoimx,snoimn,snojmx,snojmn,
58          &                     zorlmx,zorlmn,zoromx,zoromn,zorsmx,
59          &                     zorsmn,zorimx,zorimn,zorjmx, zorjmn,
60          &                     plrlmx,plrlmn,plromx,plromn,plrsmx,
61          &                     plrsmn,plrimx,plrimn,plrjmx,plrjmn,
62          &                     tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx,
63          &                     tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn,
64          &                     tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx,
65          &                     tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn,
66          &                     stclmx,stclmn,stcomx,stcomn,stcsmx,
67          &                     stcsmn,stcimx,stcimn,stcjmx,stcjmn,
68          &                     smclmx,smclmn,smcomx,smcomn,smcsmx,
69          &                     smcsmn,smcimx,smcimn,smcjmx,smcjmn,
70          &                     scvlmx,scvlmn,scvomx,scvomn,scvsmx,
71          &                     scvsmn,scvimx,scvimn,scvjmx,scvjmn,
72          &                     veglmx,veglmn,vegomx,vegomn,vegsmx,
73          &                     vegsmn,vegimx,vegimn,vegjmx,vegjmn,
74          &                     vetlmx,vetlmn,vetomx,vetomn,vetsmx,
75          &                     vetsmn,vetimx,vetimn,vetjmx,vetjmn,
76          &                     sotlmx,sotlmn,sotomx,sotomn,sotsmx,
77          &                     sotsmn,sotimx,sotimn,sotjmx,sotjmn,
78          &                     alslmx,alslmn,alsomx,alsomn,alssmx,
79          &                     alssmn,alsimx,alsimn,alsjmx,alsjmn,
80          &                     epstsf,epsalb,epssno,epswet,epszor,
81          &                     epsplr,epsoro,epssmc,epsscv,eptsfc,
82          &                     epstg3,epsais,epsacn,epsveg,epsvet,
83          &                     epssot,epsalf,qctsfs,qcsnos,qctsfi,
84          &                     aislim,snwmin,snwmax,cplrl,cplrs,
85          &                     cvegl,czors,csnol,csnos,czorl,csots,
86          &                     csotl,cvwgs,cvetl,cvets,calfs,
87          &                     fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb,
88          &                     calbl,calfl,calbs,ctsfs,grboro,
89          &                     grbmsk,ctsfl,deltf,caisl,caiss,
90          &                     fsalfl,fsalfs,flalfs,falbl,ftsfl,
91          &                     ftsfs,fzorl,fzors,fplrl,fsnos,faisl,
92          &                     faiss,fsnol,bltmsk,falbs,cvegs,percrit,
93          &                     deltsfc,critp2,critp3,blnmsk,critp1,
94          &                     fcplrl,fcplrs,fczors,fvets,fsotl,fsots,
95          &                     fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos,
96          &                     fczorl,fcalbs,fctsfl,fctsfs,fcalbl,
97          &                     falfs,falfl,fh,crit,zsca,ZTSFC,tem1,tem2
98     !Cwu [+2L] add f()l,f()s,c()l,c()s,eps() for sih, sic
99          &,                    fsihl,fsihs,fsicl,fsics,
100          &                     csihl,csihs,csicl,csics,epssih,epssic
101     !Clu [+4L] add f()l,f()s,c()l,c()s,eps() for vmn, vmx, slp, abs
102          &,                    fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps,
103          &                     fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs,
104          &                     cslpl,cslps,cabsl,cabss,epsvmn,epsvmx,
105          &                     epsslp,epsabs
106     !Cwu [+4L] add min/max for sih and sic
107          &,                    sihlmx,sihlmn,sihomx,sihomn,sihsmx,
108          &                     sihsmn,sihimx,sihimn,sihjmx,sihjmn,
109          &                     siclmx,siclmn,sicomx,sicomn,sicsmx,
110          &                     sicsmn,sicimx,sicimn,sicjmx,sicjmn
111          &,                    glacir_hice
112     !Clu [+8L] add min/max for vmn, vmx, slp, abs
113          &,                    vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx,
114          &                     vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn,
115          &                     vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx,
116          &                     vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn,
117          &                     slplmx,slplmn,slpomx,slpomn,slpsmx,
118          &                     slpsmn,slpimx,slpimn,slpjmx,slpjmn,
119          &                     abslmx,abslmn,absomx,absomn,abssmx,
120          &                     abssmn,absimx,absimn,absjmx,absjmn
121     !Cwu [+1L] add sihnew
122          &,                    sihnew
123     
124           INTEGER imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor,
125          &        irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg,
126          &        irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id,
127          &        icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih,
128          &        ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol,
129          &        icsnos,irttg3,me,KQCM, NLUNIT,IALB
130     !Clu [+1L] add irt() for vmn, vmx, slp, abs
131          &,       irtvmn, irtvmx, irtslp, irtabs
132           LOGICAL GAUSM, DEADS, QCMSK, ZNLST, MONCLM, MONANL,
133     !cggg landice mods start. 
134     !     &        MONFCS, MONMER, MONDIF
135          &        MONFCS, MONMER, MONDIF, LANDICE
136     !cggg landice mods end
137     
138           integer NUM_PARTHDS
139     !
140     !  THIS IS A limited point VERSION of SURFACE PROGRAM.
141     !
142     !  This program runs in two different modes:
143     !
144     !  1.  Analysis mode (FH=0.)
145     !
146     !      This program merges climatology, analysis and forecast guess to create
147     !      new surface fields.  If analysis file is given, the program
148     !      uses it if date of the analysis matches with IY,IM,ID,IH (see Note
149     !      below).
150     !
151     !  2.  Forecast mode (FH.GT.0.)
152     !
153     !      This program interpolates climatology to the date corresponding to the
154     !      forecast hour.  If surface analysis file is given, for the corresponding
155     !      dates, the program will use it.
156     !
157     !   NOTE:
158     !
159     !      If the date of the analysis does not match given IY,IM,ID,IH, (and FH),
160     !      the program searches an old analysis by going back 6 hours, then 12 hours,
161     !      then one day upto NREPMX days (parameter statement in the SUBROTINE FIXRD.
162     !      Now defined as 8).  This allows the user to provide non-daily analysis to
163     !      be used.  If matching field is not found, the forecast guess will be used.
164     !
165     !      Use of a combined earlier surface analyses and current analysis is
166     !      NOT allowed (as was done in the old version for snow analysis in which
167     !      old snow analysis is used in combination with initial guess), except
168     !      for sea surface temperature.  For sst anolmaly interpolation, you need to
169     !      set LANOM=.TRUE. and must provide sst analysis at initial time.
170     !
171     !      If you want to do complex merging of past and present surface field analysis,
172     !      YOU NEED TO CREATE a separate file that contains DAILY SURFACE FIELD.
173     !
174     !      For a dead start, do not supply FNBGSI or set FNBGSI='        '
175     !
176     !  LUGB           is the unit number used in this subprogram
177     !  LEN ...        Number of points on which sfccyc operates
178     !  LSOIL .. 	  Number of soil layers (2 as of April, 1994)
179     !  IY,IM,ID,IH .. Year, month, day, and hour of initial state.
180     !  FH ..          Forecast hour
181     !  RLA, RLO --    Latitude and longitudes of the LEN points
182     !  SIG1T .. Sigma level 1 temperature for dead start.  Should be on Gaussian
183     !           grid.  If not dead start, no need for dimension but set to zero
184     !           as in the example below.
185     !
186     !  Variable naming conventions:
187     !
188     !     ORO .. Orography
189     !     ALB .. Albedo
190     !     WET .. Soil wetness as defined for bucket model
191     !     SNO .. Snow DEPTH
192     !     ZOR .. Surface roughness length
193     !     VET .. Vegetation type
194     !     PLR .. Plant evaporation resistance
195     !     TSF .. Surface skin temperature.  Sea surface temp. over ocean.
196     !     TG3 .. Deep soil temperature (at 500cm)
197     !     STC .. Soil temperature (LSOIL layrs)
198     !     SMC .. Soil moisture (LSOIL layrs)
199     !     SCV .. Snow cover (not snow depth)
200     !     AIS .. Sea ice mask (0 or 1)
201     !     ACN .. Sea ice concentration (fraction)
202     !     GLA .. Glacier (permanent snow) mask (0 or 1)
203     !     MXI .. Maximum sea ice extent (0 or 1)
204     !     MSK .. Land ocean mask (0=ocean 1=land)
205     !     CNP .. Canopy water content
206     !     CV  .. Convective cloud cover
207     !     CVB .. Convective cloud base
208     !     CVT .. Convective cloud top
209     !     SLI .. LAND/SEA/SEA-ICE mask. (1/0/2 respectively)
210     !     VEG .. Vegetation cover
211     !     SOT .. Soil type
212     !Cwu [+2L] add SIH & SIC
213     !     SIH .. Sea ice thickness
214     !     SIC .. Sea ice concentration
215     !Clu [+6L] add SWD,SLC,VMN,VMX,SLP,ABS
216     !     SWD .. Actual snow depth
217     !     SLC .. Liquid soil moisture (LSOIL layers)
218     !     VMN .. Vegetation cover minimum
219     !     VMX .. Vegetation cover maximum
220     !     SLP .. Slope type
221     !     ABS .. Maximum snow albedo
222     
223     !
224     !  Definition of Land/Sea mask. SLLND for land and SLSEA for sea.
225     !  Definition of Sea/ice mask. AICICE for ice, AICSEA for sea.
226     !  TGICE=max ice temperature
227     !  RLAPSE=lapse rate for sst correction due to surface angulation
228     !
229           PARAMETER(SLLND =1.0,SLSEA =0.0)
230           PARAMETER(AICICE=1.0,AICSEA=0.0)
231           PARAMETER(TGICE=271.2)
232           PARAMETER(RLAPSE=0.65E-2)
233     !
234     !  Max/Min of fields for check and replace.
235     !
236     !     ???LMX .. Max over bare land
237     !     ???LMN .. Min over bare land
238     !     ???OMX .. Max over open ocean
239     !     ???OMN .. Min over open ocean
240     !     ???SMX .. Max over snow surface (land and sea-ice)
241     !     ???SMN .. Min over snow surface (land and sea-ice)
242     !     ???IMX .. Max over bare sea ice
243     !     ???IMN .. Min over bare sea ice
244     !     ???JMX .. Max over snow covered sea ice
245     !     ???JMN .. Min over snow covered sea ice
246     !
247           PARAMETER(OROLMX=8000.,OROLMN=-1000.,OROOMX=3000.,OROOMN=-1000.,
248          &          OROSMX=8000.,OROSMN=-1000.,OROIMX=3000.,OROIMN=-1000.,
249          &          OROJMX=3000.,OROJMN=-1000.)
250     !     PARAMETER(ALBLMX=0.80,ALBLMN=0.06,ALBOMX=0.06,ALBOMN=0.06,
251     !    &          ALBSMX=0.80,ALBSMN=0.06,ALBIMX=0.80,ALBIMN=0.80,
252     !    &          ALBJMX=0.80,ALBJMN=0.80)
253     !Cwu [-3L/+9L] change min/max for ALB; add min/max for SIH & SIC
254     !     PARAMETER(ALBLMX=0.80,ALBLMN=0.01,ALBOMX=0.01,ALBOMN=0.01,
255     !    &          ALBSMX=0.80,ALBSMN=0.01,ALBIMX=0.01,ALBIMN=0.01,
256     !    &          ALBJMX=0.01,ALBJMN=0.01)
257     !  note: the range values for bare land and snow covered land
258     !        (ALBLMX, ALBLMN, ALBSMX, ALBSMN) are set below
259     !        based on whether the old or new radiation is selected
260           PARAMETER(ALBOMX=0.06,ALBOMN=0.06,
261          &          ALBIMX=0.80,ALBIMN=0.06,
262          &          ALBJMX=0.80,ALBJMN=0.06)
263           PARAMETER(SIHLMX=0.0,SIHLMN=0.0,SIHOMX=5.0,SIHOMN=0.0,
264          &          SIHSMX=5.0,SIHSMN=0.0,SIHIMX=5.0,SIHIMN=0.10,
265          &          SIHJMX=5.0,SIHJMN=0.10,glacir_hice=3.0)
266           PARAMETER(SICLMX=0.0,SICLMN=0.0,SICOMX=1.0,SICOMN=0.0,
267          &          SICSMX=1.0,SICSMN=0.0,SICIMX=1.0,SICIMN=0.50,
268          &          SICJMX=1.0,SICJMN=0.50)
269     !
270     !     PARAMETER(SIHLMX=0.0,SIHLMN=0.0,SIHOMX=8.0,SIHOMN=0.0,
271     !    &          SIHSMX=8.0,SIHSMN=0.0,SIHIMX=8.0,SIHIMN=0.10,
272     !    &          SIHJMX=8.0,SIHJMN=0.10,glacir_hice=3.0)
273     !     PARAMETER(SICLMX=0.0,SICLMN=0.0,SICOMX=1.0,SICOMN=0.0,
274     !    &          SICSMX=1.0,SICSMN=0.0,SICIMX=1.0,SICIMN=0.15,
275     !    &          SICJMX=1.0,SICJMN=0.15)
276     
277           PARAMETER(WETLMX=0.15,WETLMN=0.00,WETOMX=0.15,WETOMN=0.15,
278          &          WETSMX=0.15,WETSMN=0.15,WETIMX=0.15,WETIMN=0.15,
279          &          WETJMX=0.15,WETJMN=0.15)
280     !Clu [-1L/+1L] revise SNOSMN (for Noah LSM)
281           PARAMETER(SNOLMX=0.0,SNOLMN=0.0,SNOOMX=0.0,SNOOMN=0.0,
282     !*   &          SNOSMX=55000.,SNOSMN=0.01,SNOIMX=0.,SNOIMN=0.0,
283     !cggg landice mods start, should SNOSMN be set to .001 as in noah
284     !cggg     &          SNOSMX=55000.,SNOSMN=0.0001,SNOIMX=0.,SNOIMN=0.0,
285          &          SNOSMX=55000.,SNOSMN=0.001,SNOIMX=0.,SNOIMN=0.0,
286     !cggg landice mods end
287          &          SNOJMX=10000.,SNOJMN=0.01)
288           PARAMETER(ZORLMX=300.,ZORLMN=2.,ZOROMX=1.0,ZOROMN=1.E-05,
289          &          ZORSMX=300.,ZORSMN=2.,ZORIMX=1.0,ZORIMN=1.0,
290          &          ZORJMX=1.0,ZORJMN=1.0)
291           PARAMETER(PLRLMX=1000.,PLRLMN=0.0,PLROMX=1000.0,PLROMN=0.0,
292          &          PLRSMX=1000.,PLRSMN=0.0,PLRIMX=1000.,PLRIMN=0.0,
293          &          PLRJMX=1000.,PLRJMN=0.0)
294     !Clu [-1L/+1L] relax TSFSMX (for Noah LSM)
295           PARAMETER(TSFLMX=353.,TSFLMN=173.0,TSFOMX=313.0,TSFOMN=271.2,
296          &          TSFSMX=305.0,TSFSMN=173.0,TSFIMX=271.2,TSFIMN=173.0,
297          &          TSFJMX=273.16,TSFJMN=173.0)
298     !     PARAMETER(TSFLMX=353.,TSFLMN=173.0,TSFOMX=313.0,TSFOMN=271.21,
299     !*   &          TSFSMX=273.16,TSFSMN=173.0,TSFIMX=271.21,TSFIMN=173.0,
300     !    &          TSFSMX=305.0,TSFSMN=173.0,TSFIMX=271.21,TSFIMN=173.0,
301           PARAMETER(TG3LMX=310.,TG3LMN=200.0,TG3OMX=310.0,TG3OMN=200.0,
302          &          TG3SMX=310.,TG3SMN=200.0,TG3IMX=310.0,TG3IMN=200.0,
303          &          TG3JMX=310.,TG3JMN=200.0)
304           PARAMETER(STCLMX=353.,STCLMN=173.0,STCOMX=313.0,STCOMN=200.0,
305          &          STCSMX=310.,STCSMN=200.0,STCIMX=310.0,STCIMN=200.0,
306          &          STCJMX=310.,STCJMN=200.0)
307     !cggg landice mods start.  force a flag value of soil moisture of 1.0
308     !                          at non-land points
309     !      PARAMETER(SMCLMX=0.55,SMCLMN=0.0,SMCOMX=0.55,SMCOMN=0.0,
310     !     &          SMCSMX=0.55,SMCSMN=0.0,SMCIMX=0.55,SMCIMN=0.0,
311     !     &          SMCJMX=0.55,SMCJMN=0.0)
312           PARAMETER(SMCLMX=0.55,SMCLMN=0.0,SMCOMX=1.0,SMCOMN=1.0,
313          &          SMCSMX=0.55,SMCSMN=0.0,SMCIMX=1.0,SMCIMN=1.0,
314          &          SMCJMX=1.0,SMCJMN=1.0)
315     !cggg landice mods end.
316           PARAMETER(SCVLMX=0.0,SCVLMN=0.0,SCVOMX=0.0,SCVOMN=0.0,
317          &          SCVSMX=1.0,SCVSMN=1.0,SCVIMX=0.0,SCVIMN=0.0,
318          &          SCVJMX=1.0,SCVJMN=1.0)
319           PARAMETER(VEGLMX=1.0,VEGLMN=0.0,VEGOMX=0.0,VEGOMN=0.0,
320          &          VEGSMX=1.0,VEGSMN=0.0,VEGIMX=0.0,VEGIMN=0.0,
321          &          VEGJMX=0.0,VEGJMN=0.0)
322     !Clu [+12L] set min/max for VMN, VMX, SLP, ABS
323           PARAMETER(VMNLMX=1.0,VMNLMN=0.0,VMNOMX=0.0,VMNOMN=0.0,
324          &          VMNSMX=1.0,VMNSMN=0.0,VMNIMX=0.0,VMNIMN=0.0,
325          &          VMNJMX=0.0,VMNJMN=0.0)   
326           PARAMETER(VMXLMX=1.0,VMXLMN=0.0,VMXOMX=0.0,VMXOMN=0.0,
327          &          VMXSMX=1.0,VMXSMN=0.0,VMXIMX=0.0,VMXIMN=0.0,
328          &          VMXJMX=0.0,VMXJMN=0.0)  
329           PARAMETER(SLPLMX=9.0,SLPLMN=1.0,SLPOMX=0.0,SLPOMN=0.0,
330     !cggg landice mods start
331     !cggg     &          SLPSMX=9.0,SLPSMN=1.0,SLPIMX=9.0,SLPIMN=9.0,
332     !cggg     &          SLPJMX=9.0,SLPJMN=9.0) 
333          &          SLPSMX=9.0,SLPSMN=1.0,SLPIMX=0.,SLPIMN=0.,
334          &          SLPJMX=0.,SLPJMN=0.) 
335     !cggg landice mods end
336     !  note: the range values for bare land and snow covered land
337     !        (ALBLMX, ALBLMN, ALBSMX, ALBSMN) are set below
338     !        based on whether the old or new radiation is selected
339           PARAMETER(ABSOMX=0.0,ABSOMN=0.0,
340          &          ABSIMX=0.0,ABSIMN=0.0,
341          &          ABSJMX=0.0,ABSJMN=0.0)    
342     !  vegetation type
343           PARAMETER(VETLMX=13.,VETLMN=1.0,VETOMX=0.0,VETOMN=0.0,
344     !cggg landice mods start
345     !cggg     &          VETSMX=13.,VETSMN=1.0,VETIMX=13.,VETIMN=13.0,
346     !cggg     &          VETJMX=13.,VETJMN=13.0)
347          &          VETSMX=13.,VETSMN=1.0,VETIMX=0.,VETIMN=0.,
348          &          VETJMX=0.,VETJMN=0.)
349     !cggg landice mods end
350     !  soil type
351           PARAMETER(SOTLMX=9.,SOTLMN=1.0,SOTOMX=0.0,SOTOMN=0.0,
352     !cggg landice mods start
353     !cggg     &          SOTSMX=9.,SOTSMN=1.0,SOTIMX=9.,SOTIMN=9.0,
354     !cggg     &          SOTJMX=9.,SOTJMN=0.0)
355          &          SOTSMX=9.,SOTSMN=1.0,SOTIMX=0.,SOTIMN=0.,
356          &          SOTJMX=0.,SOTJMN=0.)
357     !cggg landice mods end
358     !  fraction of vegetation for strongly and weakly zeneith angle dependent
359     !  albedo
360           PARAMETER(ALSLMX=1.0,ALSLMN=0.0,ALSOMX=0.0,ALSOMN=0.0,
361          &          ALSSMX=1.0,ALSSMN=0.0,ALSIMX=0.0,ALSIMN=0.0,
362          &          ALSJMX=0.0,ALSJMN=0.0)
363     !
364     !  Criteria used for monitoring
365     !
366           PARAMETER(EPSTSF=0.01,EPSALB=0.001,EPSSNO=0.01,
367          &          EPSWET=0.01,EPSZOR=0.0000001,EPSPLR=1.,EPSORO=0.,
368          &          EPSSMC=0.0001,EPSSCV=0.,EPTSFC=0.01,EPSTG3=0.01,
369          &          EPSAIS=0.,EPSACN=0.01,EPSVEG=0.01,
370     !Cwu [+1L] add eps() for sih, sic
371          &          EPSSIH=0.001,EPSSIC=0.001,
372     !Clu [+1L] add eps() for vmn, vmx, abs, slp
373          &          EPSVMN=0.01,EPSVMX=0.01,EPSABS=0.001,EPSSLP=0.01,
374          &          epsvet=.01,epssot=.01,epsalf=.001)
375     !
376     !  Quality control of analysis snow and sea ice
377     !
378     !   QCTSFS .. Surface temperature above which no snow allowed
379     !   QCSNOS .. Snow depth above which snow must exist
380     !   QCTSFI .. SST above which sea-ice is not allowed
381     !
382     !Clu relax QCTSFS (for Noah LSM)
383     !*    PARAMETER(QCTSFS=283.16,QCSNOS=100.,QCTSFI=280.16)
384     !*    PARAMETER(QCTSFS=288.16,QCSNOS=100.,QCTSFI=280.16)
385           PARAMETER(QCTSFS=293.16,QCSNOS=100.,QCTSFI=280.16)
386     !
387     !Cwu [-2L]
388     !* Ice concentration for ice limit (55 percent)
389     !
390     !*    PARAMETER(AISLIM=0.55)
391     !
392     !  Parameters to obtain snow depth from snow cover and temperature
393     !
394     !     PARAMETER(SNWMIN=25.,SNWMAX=100.)
395           PARAMETER(SNWMIN=5.0,SNWMAX=100.)
396           real (kind=kind_io8), parameter :: ten=10.0, one=1.0
397     !
398     !  COEEFICIENTS OF BLENDING FORECAST AND INTERPOLATED CLIM
399     !  (OR ANALYZED) FIELDS OVER SEA OR LAND(L) (NOT FOR CLOUDS)
400     !  1.0 = USE OF FORECAST
401     !  0.0 = REPLACE WITH INTERPOLATED ANALYSIS
402     !
403     !    These values are set for analysis mode.
404     !
405     !   Variables                  Land                 Sea
406     !   ---------------------------------------------------------
407     !   Surface temperature        Forecast             Analysis
408     !Cwu [+1L]
409     !   Surface temperature        Forecast             Forecast (over sea ice)
410     !   Albedo                     Analysis             Analysis
411     !   Sea-ice                    Analysis             Analysis
412     !   Snow                       Analysis             Forecast (over sea ice)
413     !   Roughness                  Analysis             Forecast
414     !   Plant resistance           Analysis             Analysis
415     !   Soil wetness (layer)       Weighted average     Analysis
416     !   Soil temperature           Forecast             Analysis
417     !   Canopy waver content       Forecast             Forecast
418     !   Convective cloud cover     Forecast             Forecast
419     !   Convective cloud bottm     Forecast             Forecast
420     !   Convective cloud top       Forecast             Forecast
421     !   Vegetation cover           Analysis             Analysis
422     !   vegetation type            Analysis             Analysis
423     !   soil type                  Analysis             Analysis
424     !Cwu [+2L]
425     !   Sea-ice thickness          Forecast             Forecast
426     !   Sea-ice concentration      Analysis             Analysis
427     !Clu [+6L]
428     !   Vegetation cover min       Analysis             Analysis
429     !   Vegetation cover max       Analysis             Analysis
430     !   Max snow albedo            Analysis             Analysis
431     !   Slope type                 Analysis             Analysis
432     !   Liquid Soil wetness        Analysis-weighted    Analysis
433     !   Actual snow depth          Analysis-weighted    Analysis
434     !
435     !  Note: If analysis file is not given, then time interpolated climatology
436     !        is used.  If analyiss file is given, it will be used as far as the
437     !        date and time matches.  If they do not match, it uses forecast.
438     !
439     !  Critical percentage value for aborting bad points when LGCHEK=.TRUE.
440     !
441           LOGICAL LGCHEK
442           DATA LGCHEK/.TRUE./
443           DATA CRITP1,CRITP2,CRITP3/80.,80.,25./
444     !
445     !     integer kpdalb(4), kpdalf(2)
446     !     data kpdalb/212,215,213,216/, kpdalf/214,217/
447     !     save kpdalb, kpdalf
448     !
449     !  MASK OROGRAPHY AND VARIANCE ON GAUSSIAN GRID
450     !
451           REAL (KIND=KIND_IO8) SLMASK(LEN),OROG(LEN)
452           REAL (KIND=KIND_IO8) RLA(LEN), RLO(LEN)
453     !
454     !  Permanent/extremes
455     !
456           CHARACTER*500 FNGLAC,FNMXIC
457           real (kind=kind_io8), allocatable :: GLACIR(:),AMXICE(:),TSFCL0(:)
458     !
459     !     TSFCL0 is the climatological TSF at FH=0
460     !
461     !  CLIMATOLOGY SURFACE FIELDS (Last character 'C' or 'CLM' indicate CLIMATOLOGY)
462     !
463           CHARACTER*500 FNTSFC,FNWETC,FNSNOC,FNZORC,FNALBC,FNAISC,
464          &              FNPLRC,FNTG3C,FNSCVC,FNSMCC,FNSTCC,FNACNC,
465          &              FNVEGC,fnvetc,fnsotc
466     !Clu [+1L] add FN()C for vmn, vmx, slp, abs
467          &,             FNVMNC,FNVMXC,FNSLPC,FNABSC, FNALBC2 
468           REAL (KIND=KIND_IO8) TSFCLM(LEN), WETCLM(LEN),   SNOCLM(LEN),
469          &     ZORCLM(LEN), ALBCLM(LEN,4), AISCLM(LEN),
470          &     TG3CLM(LEN), ACNCLM(LEN),   CNPCLM(LEN),
471          &     CVCLM (LEN), CVBCLM(LEN),   CVTCLM(LEN),
472          &     SCVCLM(LEN), TSFCL2(LEN),   VEGCLM(LEN),
473          &     vetclm(LEN), sotclm(LEN),   ALFCLM(LEN,2), SLICLM(LEN),
474          &     SMCCLM(LEN,LSOIL), STCCLM(LEN,LSOIL)
475     !Cwu [+1L] add ()CLM for sih, sic
476          &,    SIHCLM(LEN), SICCLM(LEN)
477     !Clu [+1L] add ()CLM for vmn, vmx, slp, abs
478          &,    VMNCLM(LEN), VMXCLM(LEN), SLPCLM(LEN), ABSCLM(LEN)
479     !
480     !  ANALYZED SURFACE FIELDS (Last character 'A' or 'ANL' indicate ANALYSIS)
481     !
482           CHARACTER*500 FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
483          &             FNPLRA,FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,
484          &             FNVEGA,fnveta,fnsota
485     !Clu [+1L] add FN()A for vmn, vmx, slp, abs
486          &,            FNVMNA,FNVMXA,FNSLPA,FNABSA       
487     !
488           REAL (KIND=KIND_IO8) TSFANL(LEN), WETANL(LEN),   SNOANL(LEN),
489          &     ZORANL(LEN), ALBANL(LEN,4), AISANL(LEN),
490          &     TG3ANL(LEN), ACNANL(LEN),   CNPANL(LEN),
491          &     CVANL (LEN), CVBANL(LEN),   CVTANL(LEN),
492          &     SCVANL(LEN), TSFAN2(LEN),   VEGANL(LEN),
493          &     vetanl(LEN), sotanl(LEN),   ALFANL(LEN,2), SLIANL(LEN),
494          &     SMCANL(LEN,LSOIL), STCANL(LEN,LSOIL)
495     !Cwu [+1L] add SIHANL & SICANL
496          &,    SIHANL(LEN), SICANL(LEN)
497     !Clu [+1L] add ()ANL for vmn, vmx, slp, abs
498          &,    VMNANL(LEN), VMXANL(LEN), SLPANL(LEN), ABSANL(LEN)
499     !
500           REAL (KIND=KIND_IO8) TSFAN0(LEN) !  Sea surface temperature analysis at FT=0.
501     !
502     !  PREDICTED SURFACE FIELDS (Last characters 'FCS' indicates FORECAST)
503     !
504           REAL (KIND=KIND_IO8) TSFFCS(LEN), WETFCS(LEN),   SNOFCS(LEN),
505          &     ZORFCS(LEN), ALBFCS(LEN,4), AISFCS(LEN),
506          &     TG3FCS(LEN), ACNFCS(LEN),   CNPFCS(LEN),
507          &     CVFCS (LEN), CVBFCS(LEN),   CVTFCS(LEN),
508          &     SLIFCS(LEN), VEGFCS(LEN),
509          &     vetfcs(LEN), sotfcs(LEN),   alffcs(LEN,2),
510          &     SMCFCS(LEN,LSOIL), STCFCS(LEN,LSOIL)
511     !Cwu [+1L] add SIHFCS & SICFCS
512          &,    SIHFCS(LEN), SICFCS(LEN), SITFCS(LEN)
513     !Clu [+2L] add ()FCS for VMN, VMX, SLP, ABS, SWD, SLC
514          &,    VMNFCS(LEN), VMXFCS(LEN), SLPFCS(LEN), ABSFCS(LEN)
515          &,    SWDFCS(LEN), SLCFCS(LEN,LSOIL)
516     !
517     ! Ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched
518     ! in this program).
519     !
520           REAL (KIND=KIND_IO8) F10M  (LEN)
521           REAL (KIND=KIND_IO8) FSMCL(25),FSMCS(25),FSTCL(25),FSTCS(25)
522           REAL (KIND=KIND_IO8) FCSMCL(25),FCSMCS(25),FCSTCL(25),FCSTCS(25)
523     
524     !Clu [+1L] add SWRATIO (soil moisture liquid-to-total ratio)
525           REAL (KIND=KIND_IO8) SWRATIO(LEN,LSOIL)
526     !Clu [+1L] add FIXRATIO (option to adjust slc from smc)
527           LOGICAL FIXRATIO(LSOIL)
528     !
529           INTEGER ICSMCL(25), ICSMCS(25), ICSTCL(25), ICSTCS(25)
530     !
531           REAL (KIND=KIND_IO8) CSMCL(25), CSMCS(25)
532           REAL (KIND=KIND_IO8) CSTCL(25), CSTCS(25)
533     !
534     !Clu [-1L/+1L] increase the dimension size
535     !Clu  REAL (KIND=KIND_IO8) SLMSKH(2048*1024)
536           REAL (KIND=KIND_IO8) SLMSKH(2500*1250)
537     !     REAL (KIND=KIND_IO8) SLMSKH(5800*2900)    ! hmhj
538           CHARACTER*500 FNMSKH
539           Integer kpd9
540     !
541           logical icefl1(len), icefl2(len)
542     !
543     !  Input and output SURFACE FIELDS (BGES) file names
544     !
545     !
546     !  Sigma level 1 temperature for dead start
547     !
548           REAL (KIND=KIND_IO8) SIG1T(LEN), WRK(LEN)
549     !
550           CHARACTER*32 LABEL
551     !
552     !  = 1 ==> FORECAST IS USED
553     !  = 0 ==> ANALYSIS (OR CLIMATOLOGY) IS USED
554     !
555     !     OUTPUT FILE  ... PRIMARY SURFACE FILE FOR RADIATION AND FORECAST
556     !
557     !       REC.  1    LABEL
558     !       REC.  2    DATE RECORD
559     !       REC.  3    TSF
560     !       REC.  4    SOILM(TWO LAYERS)              ----> 4 layers
561     !       REC.  5    SNOW
562     !       REC.  6    SOILT(TWO LAYERS)              ----> 4 layers
563     !       REC.  7    TG3
564     !       REC.  8    ZOR
565     !       REC.  9    CV
566     !       REC. 10    CVB
567     !       REC. 11    CVT
568     !       REC. 12    ALBEDO (four types)
569     !       REC. 13    SLIMSK
570     !       REC. 14    vegetation cover
571     !       REC. 14    PLANTR                         -----> skip this record
572     !       REC. 15    F10M                           -----> CANOPY
573     !       REC. 16    CANOPY WATER CONTENT (CNPANL)  -----> F10M
574     !       REC. 17    vegetation type
575     !       REC. 18    soil type
576     !       REC. 19    zeneith angle dependent vegetation fraction (two types)
577     !       REC. 20    UUSTAR
578     !       REC. 21    FFMM
579     !       REC. 22    FFHH
580     !Cwu add SIH & SIC
581     !       REC. 23    SIH(one category only)
582     !       REC. 24    SIC
583     !Clu [+8L] add PRCP, FLAG, SWD, SLC, VMN, VMX, SLP, ABS
584     !       REC. 25    TPRCP
585     !       REC. 26    SRFLAG
586     !       REC. 27    SWD
587     !       REC. 28    SLC (4 LAYERS)
588     !       REC. 29    VMN
589     !       REC. 30    VMX
590     !       REC. 31    SLP
591     !       REC. 32    ABS
592     
593     !
594     !  Debug only
595     !   LDEBUG=.TRUE. creates BGES files for climatology and analysis
596     !   LQCBGS=.TRUE. Quality controls input BGES file before merging (should have been
597     !              QCed in the forecast program)
598     !
599           LOGICAL LDEBUG,LQCBGS
600           logical lprnt
601     !
602     !  Debug only
603     !
604           CHARACTER*500 FNDCLM,FNDANL
605     !
606           LOGICAL LANOM
607     !
608           NAMELIST/NAMSFC/FNGLAC,FNMXIC,
609          &                FNTSFC,FNWETC,FNSNOC,FNZORC,FNALBC,FNAISC,
610          &                FNPLRC,FNTG3C,FNSCVC,FNSMCC,FNSTCC,FNACNC,
611          &                FNVEGC,fnvetc,fnsotc,FNALBC2,
612     !Clu [+1L]  add fn()c for vmn, vmx, slp, abs
613          &                FNVMNC,FNVMXC,FNSLPC,FNABSC,
614          &                FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
615          &                FNPLRA,FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,
616          &                FNVEGA,fnveta,fnsota,
617     !Clu [+1L]  add fn()a for vmn, vmx, slp, abs
618          &                FNVMNA,FNVMXA,FNSLPA,FNABSA,
619          &                FNMSKH,
620          &                LDEBUG,LGCHEK,LQCBGS,CRITP1,CRITP2,CRITP3,
621          &                FNDCLM,FNDANL,
622          &                LANOM,
623          &                FTSFL,FTSFS,FALBL,FALBS,FAISL,FAISS,FSNOL,FSNOS,
624          &                FZORL,FZORS,FPLRL,FPLRS,FSMCL,FSMCS,
625          &                FSTCL,FSTCS,fvegl,fvegs,fvetl,fvets,fsotl,fsots,
626          &                FCTSFL,FCTSFS,FCALBL,FCALBS,FCSNOL,FCSNOS,
627          &                FCZORL,FCZORS,FCPLRL,FCPLRS,FCSMCL,FCSMCS,
628          &                FCSTCL,FCSTCS,fsalfl,fsalfs,fcalfl,flalfs,
629     !Cwu [+1L]  add f()l and f()s for sih, sic and aislim, sihnew
630          &                FSIHL,FSICL,FSIHS,FSICS,AISLIM,SIHNEW,
631     !Clu [+2L]  add f()l and f()s for vmn, vmx, slp, abs
632          &                FVMNL,FVMNS,FVMXL,FVMXS,FSLPL,FSLPS,
633          &                FABSL,FABSS,
634          &                ICTSFL,ICTSFS,ICALBL,ICALBS,ICSNOL,ICSNOS,
635          &                ICZORL,ICZORS,ICPLRL,ICPLRS,ICSMCL,ICSMCS,
636          &                ICSTCL,ICSTCS,icalfl,icalfs,
637     !
638          &                GAUSM,  DEADS, QCMSK, ZNLST,
639          &                MONCLM, MONANL, MONFCS, MONMER, MONDIF, IGRDBG,
640     !cggg landice mods start
641     !     &                BLNMSK, BLTMSK
642          &                BLNMSK, BLTMSK, LANDICE
643     !cggg landice mods end
644     !
645           DATA GAUSM/.TRUE./,  DEADS/.FALSE./, BLNMSK/0.0/, BLTMSK/90.0/
646          &,    QCMSK/.FALSE./, ZNLST/.FALSE./, IGRDBG/-1/
647          &,    MONCLM/.FALSE./, MONANL/.FALSE./, MONFCS/.FALSE./
648     !cggg landice mods start
649     !     &,    MONMER/.FALSE./,  MONDIF/.FALSE./
650          &,    MONMER/.FALSE./,  MONDIF/.FALSE./,  LANDICE/.TRUE./
651     !cggg landice mods end
652     !
653     !  Defaults file names
654     !
655           DATA FNMSKH/'global_slmask.t126.grb'/
656           DATA FNALBC/'global_albedo4.1x1.grb'/
657           DATA FNALBC2/'/nwprod/fix/global_albedo4.1x1.grb'/
658           DATA FNTSFC/'global_sstclim.2x2.grb'/
659           DATA FNSOTC/'global_soiltype.1x1.grb'/
660           DATA FNVEGC/'global_vegfrac.1x1.grb'/
661           DATA FNVETC/'global_vegtype.1x1.grb'/
662           DATA FNGLAC/'global_glacier.2x2.grb'/
663           DATA FNMXIC/'global_maxice.2x2.grb'/
664           DATA FNSNOC/'global_snoclim.1.875.grb'/
665           DATA FNZORC/'global_zorclim.1x1.grb'/
666           DATA FNAISC/'global_iceclim.2x2.grb'/
667           DATA FNTG3C/'global_tg3clim.2.6x1.5.grb'/
668           DATA FNSMCC/'global_soilmcpc.1x1.grb'/
669     !Clu [+4L] add fn()c for vmn, vmx, abs, slp
670           DATA FNVMNC/'global_shdmin.0.144x0.144.grb'/
671           DATA FNVMXC/'global_shdmax.0.144x0.144.grb'/
672           DATA FNSLPC/'global_slope.1x1.grb'/
673           DATA FNABSC/'global_snoalb.1x1.grb'/
674     !
675           DATA FNWETC/'        '/
676           DATA FNPLRC/'        '/
677           DATA FNSTCC/'        '/
678           DATA FNSCVC/'        '/
679           DATA FNACNC/'        '/
680     !
681           DATA FNTSFA/'        '/
682           DATA FNWETA/'        '/
683           DATA FNSNOA/'        '/
684           DATA FNZORA/'        '/
685           DATA FNALBA/'        '/
686           DATA FNAISA/'        '/
687           DATA FNPLRA/'        '/
688           DATA FNTG3A/'        '/
689           DATA FNSMCA/'        '/
690           DATA FNSTCA/'        '/
691           DATA FNSCVA/'        '/
692           DATA FNACNA/'        '/
693           DATA FNVEGA/'        '/
694           DATA FNVETA/'        '/
695           DATA FNSOTA/'        '/
696     !Clu [+4L] add fn()a for vmn, vmx, abs, slp
697           DATA FNVMNA/'        '/
698           DATA FNVMXA/'        '/
699           DATA FNSLPA/'        '/
700           DATA FNABSA/'        '/
701     !
702           DATA LDEBUG/.FALSE./, LQCBGS/.TRUE./
703           DATA FNDCLM/'        '/
704           DATA FNDANL/'        '/
705           DATA LANOM/.FALSE./
706     !
707     !  DEFAULT RELAXATION TIME IN HOURS TO ANALYSIS OR CLIMATOLOGY
708           DATA FTSFL/99999.0/,  FTSFS/0.0/
709           DATA FALBL/0.0/,      FALBS/0.0/
710           DATA FALFL/0.0/,      FALFS/0.0/
711           DATA FAISL/0.0/,      FAISS/0.0/
712           DATA FSNOL/0.0/,      FSNOS/99999.0/
713           DATA FZORL/0.0/,      FZORS/99999.0/
714           DATA FPLRL/0.0/,      FPLRS/0.0/
715           DATA FvetL/0.0/,      FvetS/99999.0/
716           DATA FsotL/0.0/,      FsotS/99999.0/
717           DATA FVegL/0.0/,      FvegS/99999.0/
718     !Cwu [+4L] add f()l and f()s for sih, sic and aislim, sihlim
719           DATA FsihL/99999.0/,  FsihS/99999.0/
720     !     DATA FsicL/99999.0/,  FsicS/99999.0/
721           DATA FsicL/0.0/,      FsicS/0.0/
722     !  DEFAULT ice concentration limit (50%), new ice thickness (20cm)
723           DATA AISLIM/0.50/,    SIHNEW/0.2/
724     !Clu [+4L] add f()l and f()s for vmn, vmx, abs, slp
725           DATA FvmnL/0.0/,      FvmnS/99999.0/
726           DATA FvmxL/0.0/,      FvmxS/99999.0/
727           DATA FslpL/0.0/,      FslpS/99999.0/
728           DATA FabsL/0.0/,      FabsS/99999.0/
729     !  DEFAULT RELAXATION TIME IN HOURS TO CLIMATOLOGY IF ANALYSIS MISSING
730           DATA FCTSFL/99999.0/, FCTSFS/99999.0/
731           DATA FCALBL/99999.0/, FCALBS/99999.0/
732           DATA FCSNOL/99999.0/, FCSNOS/99999.0/
733           DATA FCZORL/99999.0/, FCZORS/99999.0/
734           DATA FCPLRL/99999.0/, FCPLRS/99999.0/
735     !  DEFAULT FLAG TO APPLY CLIMATOLOGICAL ANNUAL CYCLE
736           DATA ICTSFL/0/, ICTSFS/1/
737           DATA ICALBL/1/, ICALBS/1/
738           DATA ICALFL/1/, ICALFS/1/
739           DATA ICSNOL/0/, ICSNOS/0/
740           DATA ICZORL/1/, ICZORS/0/
741           DATA ICPLRL/1/, ICPLRS/0/
742     !
743           DATA CCNP/1.0/
744           DATA CCV/1.0/,   CCVB/1.0/, CCVT/1.0/
745     !
746           DATA IFP/0/
747     !
748           SAVE IFP,FNGLAC,FNMXIC,
749          &     FNTSFC,FNWETC,FNSNOC,FNZORC,FNALBC,FNAISC,
750          &     FNPLRC,FNTG3C,FNSCVC,FNSMCC,FNSTCC,FNACNC,FNVEGC,
751          &     FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
752          &     FNPLRA,FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,FNVEGA,
753          &     fnvetc,fnveta,
754          &     fnsotc,fnsota,
755     !Clu [+2L] add fn()c and fn()a for vmn, vmx, slp, abs
756          &     FNVMNC,FNVMXC,FNABSC,FNSLPC,
757          &     FNVMNA,FNVMXA,FNABSA,FNSLPA,
758          &     LDEBUG,LGCHEK,LQCBGS,CRITP1,CRITP2,CRITP3,
759          &     FNDCLM,FNDANL,
760          &     LANOM,
761          &     FTSFL,FTSFS,FALBL,FALBS,FAISL,FAISS,FSNOL,FSNOS,
762          &     FZORL,FZORS,FPLRL,FPLRS,FSMCL,FSMCS,falfl,falfs,
763          &     FSTCL,FSTCS,fvegl,fvegs,fvetl,fvets,fsotl,fsots,
764          &     FCTSFL,FCTSFS,FCALBL,FCALBS,FCSNOL,FCSNOS,
765          &     FCZORL,FCZORS,FCPLRL,FCPLRS,FCSMCL,FCSMCS,
766          &     FCSTCL,FCSTCS,fcalfl,fcalfs,
767     !Cwu [+1L] add f()l and f()s for sih, sic and aislim, sihnew
768          &     FSIHL,FSIHS,FSICL,FSICS,AISLIM,SIHNEW,
769     !Clu [+2L] add f()l and f()s for vmn, vmx, slp, abs
770          &     FVMNL,FVMNS,FVMXL,FVMXS,FSLPL,FSLPS,
771          &     FABSL,FABSS,
772          &     ICTSFL,ICTSFS,ICALBL,ICALBS,ICSNOL,ICSNOS,
773          &     ICZORL,ICZORS,ICPLRL,ICPLRS,ICSMCL,ICSMCS,
774          &     ICSTCL,ICSTCS,icalfl,icalfs,
775          &     GAUSM, DEADS, QCMSK,
776          &     MONCLM, MONANL, MONFCS, MONMER, MONDIF, IGRDBG,
777          &     GRBORO, GRBMSK,
778     !
779          &     CTSFL,  CTSFS,  CALBL, CALFL, CALBS, CALFS, CSMCS,
780          &     CSNOL,  CSNOS,  CZORL, CZORS, CPLRL, CPLRS, CSTCL,
781          &     CSTCS,  CvegL,  CvwgS, CvetL, CvetS, CsotL, CsotS,
782          &     CSMCL
783     !Cwu [+1L] add c()l and c()s for sih, sic
784          &,    CSIHL,  CSIHS,  CSICL, CSICS
785     !Clu [+2L] add c()l and c()s for vmn, vmx, slp, abs
786          &,    CVMNL,  CVMNS,  CVMXL, CVMXS, CSLPL, CSLPS,
787          &     CABSL,  CABSS
788          &,    IMSK, JMSK, SLMSKH, BLNMSK, BLTMSK
789          &,    GLACIR, AMXICE, TSFCL0
790          &,    caisl, caiss, cvegs
791     !
792           lprnt = .false.
793           iprnt = 1
794     !     do i=1,len
795     !       if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i)
796     !    *,' rlo=',rlo(i)
797     !       tem1 = abs(rla(i) - 48.75)
798     !       tem2 = abs(rlo(i) - (-68.50))
799     !       if(tem1 .lt. 0.25 .and. tem2 .lt. 0.50) then
800     !         lprnt = .true.
801     !         iprnt = i
802     !         print *,' lprnt=',lprnt,' iprnt=',iprnt
803     !         print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i)
804     !       endif
805     !     enddo
806           if (ialb == 1) then
807             kpdabs = kpdabs_1
808             kpdalb = kpdalb_1
809             alblmx = .99
810             albsmx = .99
811             alblmn = .01
812             albsmn = .01
813             abslmx = 1.0
814             abssmx = 1.0
815             abssmn = .01
816             abslmn = .01
817           else
818             kpdabs = kpdabs_0
819             kpdalb = kpdalb_0
820             alblmx = .80
821             albsmx = .80
822             alblmn = .06
823             albsmn = .06
824             abslmx = .80
825             abssmx = .80
826             abslmn = .01
827             abssmn = .01
828           endif
829           IF(IFP.EQ.0) THEN
830             IFP = 1
831             DO K=1,LSOIL
832               FSMCL(K) = 99999.
833               FSMCS(K) = 0.
834               FSTCL(K) = 99999.
835               FSTCS(K) = 0.
836             ENDDO
837             rewind(NLUNIT)
838             READ (NLUNIT,NAMSFC)
839     !       WRITE(6,NAMSFC)
840     !
841             if (me .eq. 0) then
842               print *,'FTSFL,FALBL,FAISL,FSNOL,FSMCL,FZORL,FSTCL=',
843          &    FTSFL,FALBL,FAISL,FSNOL,FSMCL,FZORL,FSTCL
844               print *,'FTSFS,FALBS,FAISS,FSNOS,FSMCS,FZORS,FSTCS=',
845          &    FTSFS,FALBS,FAISS,FSNOS,FSMCS,FZORS,FSTCS
846               print *,' AISLIM=',aislim,' SIHNEW=',SIHNEW
847             endif
848     !
849             DELTF = DELTSFC / 24.0
850     !
851             CTSFL=0.                       !...  tsfc over land
852             IF(FTSFL.GE.99999.) CTSFL=1.
853             IF((FTSFL.GT.0.).AND.(FTSFL.LT.99999))  CTSFL=EXP(-DELTF/FTSFL)
854     !
855             CTSFS=0.                       !...  tsfc over sea
856             IF(FTSFS.GE.99999.) CTSFS=1.
857             IF((FTSFS.GT.0.).AND.(FTSFS.LT.99999))  CTSFS=EXP(-DELTF/FTSFS)
858     !
859             DO K=1,LSOIL
860               CSMCL(K)=0.                  !...  soilm over land
861               IF(FSMCL(K).GE.99999.) CSMCL(K)=1.
862               IF((FSMCL(K).GT.0.).AND.(FSMCL(K).LT.99999))
863          &                           CSMCL(K)=EXP(-DELTF/FSMCL(K))
864               CSMCS(K)=0.                  !...  soilm over sea
865               IF(FSMCS(K).GE.99999.) CSMCS(K)=1.
866               IF((FSMCS(K).GT.0.).AND.(FSMCS(K).LT.99999))
867          &                           CSMCS(K)=EXP(-DELTF/FSMCS(K))
868             ENDDO
869     !
870             CALBL=0.                       !...  albedo over land
871             IF(FALBL.GE.99999.) CALBL=1.
872             IF((FALBL.GT.0.).AND.(FALBL.LT.99999))  CALBL=EXP(-DELTF/FALBL)
873     !
874             CALFL=0.                       !...  fraction field for albedo over land
875             IF(FALFL.GE.99999.) CALFL=1.
876             IF((FALFL.GT.0.).AND.(FALFL.LT.99999))  CALFL=EXP(-DELTF/FALFL)
877     !
878             CALBS=0.                       !...  albedo over sea
879             IF(FALBS.GE.99999.) CALBS=1.
880             IF((FALBS.GT.0.).AND.(FALBS.LT.99999))  CALBS=EXP(-DELTF/FALBS)
881     !
882             CALFS=0.                       !...  fraction field for albedo over sea
883             IF(FALFS.GE.99999.) CALFS=1.
884             IF((FALFS.GT.0.).AND.(FALFS.LT.99999))  CALFS=EXP(-DELTF/FALFS)
885     !
886             CAISL=0.                       !...  sea ice over land
887             IF(FAISL.GE.99999.) CAISL=1.
888             IF((FAISL.GT.0.).AND.(FAISL.LT.99999))  CAISL=1.
889     !
890             CAISS=0.                       !...  sea ice over sea
891             IF(FAISS.GE.99999.) CAISS=1.
892             IF((FAISS.GT.0.).AND.(FAISS.LT.99999))  CAISS=1.
893     !
894             CSNOL=0.                       !...  snow over land
895             IF(FSNOL.GE.99999.) CSNOL=1.
896             IF((FSNOL.GT.0.).AND.(FSNOL.LT.99999))  CSNOL=EXP(-DELTF/FSNOL)
897     !       Using the same way to bending snow as NARR when FSNOL is the negative value
898     !       The magnitude of FSNOL is the thread to determine the lower and upper bound
899     !       of final SWE
900             IF(FSNOL.LT.0.)CSNOL=FSNOL
901     !
902             CSNOS=0.                       !...  snow over sea
903             IF(FSNOS.GE.99999.) CSNOS=1.
904             IF((FSNOS.GT.0.).AND.(FSNOS.LT.99999))  CSNOS=EXP(-DELTF/FSNOS)
905     !
906             CZORL=0.                       !...  roughness length over land
907             IF(FZORL.GE.99999.) CZORL=1.
908             IF((FZORL.GT.0.).AND.(FZORL.LT.99999))  CZORL=EXP(-DELTF/FZORL)
909     !
910             CZORS=0.                       !...  roughness length over sea
911             IF(FZORS.GE.99999.) CZORS=1.
912             IF((FZORS.GT.0.).AND.(FZORS.LT.99999))  CZORS=EXP(-DELTF/FZORS)
913     !
914     !       CPLRL=0.                       !...  plant resistance over land
915     !       IF(FPLRL.GE.99999.) CPLRL=1.
916     !       IF((FPLRL.GT.0.).AND.(FPLRL.LT.99999))  CPLRL=EXP(-DELTF/FPLRL)
917     !
918     !       CPLRS=0.                       !...  plant resistance over sea
919     !       IF(FPLRS.GE.99999.) CPLRS=1.
920     !       IF((FPLRS.GT.0.).AND.(FPLRS.LT.99999))  CPLRS=EXP(-DELTF/FPLRS)
921     !
922             DO K=1,LSOIL
923                CSTCL(K)=0.                 !...  soilt over land
924                IF(FSTCL(K).GE.99999.) CSTCL(K)=1.
925                IF((FSTCL(K).GT.0.).AND.(FSTCL(K).LT.99999))
926          &                            CSTCL(K)=EXP(-DELTF/FSTCL(K))
927               CSTCS(K)=0.                  !...  soilt over sea
928               IF(FSTCS(K).GE.99999.) CSTCS(K)=1.
929               IF((FSTCS(K).GT.0.).AND.(FSTCS(K).LT.99999))
930          &                           CSTCS(K)=EXP(-DELTF/FSTCS(K))
931             ENDDO
932     !
933             CvegL=0.                       !...  Vegetation fraction over land
934             IF(FvegL.GE.99999.) CvegL=1.
935             IF((FvegL.GT.0.).AND.(FvegL.LT.99999))  CvegL=EXP(-DELTF/FvegL)
936     !
937             CvegS=0.                       !...  Vegetation fraction over sea
938             IF(FvegS.GE.99999.) CvegS=1.
939             IF((FvegS.GT.0.).AND.(FvegS.LT.99999))  CvegS=EXP(-DELTF/FvegS)
940     !
941             CvetL=0.                       !...  Vegetation type over land
942             IF(FvetL.GE.99999.) CvetL=1.
943             IF((FvetL.GT.0.).AND.(FvetL.LT.99999))  CvetL=EXP(-DELTF/FvetL)
944     !
945             CvetS=0.                       !...  Vegetation type over sea
946             IF(FvetS.GE.99999.) CvetS=1.
947             IF((FvetS.GT.0.).AND.(FvetS.LT.99999))  CvetS=EXP(-DELTF/FvetS)
948     !
949             CsotL=0.                       !...  Soil type over land
950             IF(FsotL.GE.99999.) CsotL=1.
951             IF((FsotL.GT.0.).AND.(FsotL.LT.99999))  CsotL=EXP(-DELTF/FsotL)
952     !
953             CsotS=0.                       !...  Soil type over sea
954             IF(FsotS.GE.99999.) CsotS=1.
955             IF((FsotS.GT.0.).AND.(FsotS.LT.99999))  CsotS=EXP(-DELTF/FsotS)
956     
957     !Cwu [+16L]---------------------------------------------------------------
958     !
959             CsihL=0.                       !...  Sea ice thickness over land
960             IF(FsihL.GE.99999.) CsihL=1.
961             IF((FsihL.GT.0.).AND.(FsihL.LT.99999))  CsihL=EXP(-DELTF/FsihL)
962     !
963             CsihS=0.                       !...  Sea ice thickness over sea
964             IF(FsihS.GE.99999.) CsihS=1.
965             IF((FsihS.GT.0.).AND.(FsihS.LT.99999))  CsihS=EXP(-DELTF/FsihS)
966     !
967             CsicL=0.                       !...  Sea ice concentration over land
968             IF(FsicL.GE.99999.) CsicL=1.
969             IF((FsicL.GT.0.).AND.(FsicL.LT.99999))  CsicL=EXP(-DELTF/FsicL)
970     !
971             CsicS=0.                       !...  Sea ice concentration over sea
972             IF(FsicS.GE.99999.) CsicS=1.
973             IF((FsicS.GT.0.).AND.(FsicS.LT.99999))  CsicS=EXP(-DELTF/FsicS)
974     
975     !Clu [+32L]---------------------------------------------------------------
976     !
977             CvmnL=0.                       !...  Min Veg cover over land
978             IF(FvmnL.GE.99999.) CvmnL=1.
979             IF((FvmnL.GT.0.).AND.(FvmnL.LT.99999))  CvmnL=EXP(-DELTF/FvmnL)
980     !
981             CvmnS=0.                       !...  Min Veg cover over sea
982             IF(FvmnS.GE.99999.) CvmnS=1.
983             IF((FvmnS.GT.0.).AND.(FvmnS.LT.99999))  CvmnS=EXP(-DELTF/FvmnS)
984     !
985             CvmxL=0.                       !...  Max Veg cover over land
986             IF(FvmxL.GE.99999.) CvmxL=1.
987             IF((FvmxL.GT.0.).AND.(FvmxL.LT.99999))  CvmxL=EXP(-DELTF/FvmxL)
988     !
989             CvmxS=0.                       !...  Max Veg cover over sea
990             IF(FvmxS.GE.99999.) CvmxS=1.
991             IF((FvmxS.GT.0.).AND.(FvmxS.LT.99999))  CvmxS=EXP(-DELTF/FvmxS)
992     !
993             CslpL=0.                       !... Slope type over land
994             IF(FslpL.GE.99999.) CslpL=1.
995             IF((FslpL.GT.0.).AND.(FslpL.LT.99999))  CslpL=EXP(-DELTF/FslpL)
996     !
997             CslpS=0.                       !...  Slope type over sea
998             IF(FslpS.GE.99999.) CslpS=1.
999             IF((FslpS.GT.0.).AND.(FslpS.LT.99999))  CslpS=EXP(-DELTF/FslpS)
1000     !
1001             CabsL=0.                       !... Snow albedo over land
1002             IF(FabsL.GE.99999.) CabsL=1.
1003             IF((FabsL.GT.0.).AND.(FabsL.LT.99999))  CabsL=EXP(-DELTF/FabsL)
1004     !
1005             CabsS=0.                       !... Snow albedo over sea
1006             IF(FabsS.GE.99999.) CabsS=1.
1007             IF((FabsS.GT.0.).AND.(FabsS.LT.99999))  CabsS=EXP(-DELTF/FabsS)
1008     !Clu ----------------------------------------------------------------------
1009     !
1010     !     Read a high resolution MASK field for use in grib interpolation
1011     !
1012             CALL HMSKRD(LUGB,IMSK,JMSK,FNMSKH,
1013          &              KPDMSK,SLMSKH,GAUSM,BLNMSK,BLTMSK,me)
1014     !       IF (QCMSK) CALL QCMASK(SLMSKH,SLLND,SLSEA,IMSK,JMSK,RLA,RLO)
1015     !
1016             if (me .eq. 0) then
1017               WRITE(6,*) ' '
1018               WRITE(6,*) ' LUGB=',LUGB,' LEN=',LEN, ' LSOIL=',LSOIL
1019               WRITE(6,*) 'IY=',IY,' IM=',IM,' ID=',ID,' IH=',IH,' FH=',FH
1020          &,            ' SIG1T(1)=',SIG1T(1)
1021          &,            ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk
1022               WRITE(6,*) ' '
1023             endif
1024     !
1025     !  Reading Permanent/extreme features (glacier points and maximum ice extent)
1026     !
1027             allocate (TSFCL0(LEN))
1028             allocate (GLACIR(LEN))
1029             allocate (AMXICE(LEN))
1030     !
1031     !  Read Glacier
1032     !
1033             kpd9 = -1
1034             CALL FIXRDC(LUGB,FNGLAC,KPDGLA,kpd9,SLMASK,
1035          &              GLACIR,LEN,IRET
1036          &,             IMSK, JMSK, SLMSKH, GAUSM, BLNMSK, BLTMSK
1037          &,             RLA, RLO, me)
1038     !     ZNNT=1.
1039     !     CALL NNTPRT(GLACIR,LEN,ZNNT)
1040     !
1041     !  Read Maximum ice extent
1042     !
1043             CALL FIXRDC(LUGB,FNMXIC,KPDMXI,kpd9,SLMASK,
1044          &              AMXICE,LEN,IRET
1045          &,             IMSK, JMSK, SLMSKH, GAUSM, BLNMSK, BLTMSK
1046          &,             RLA, RLO, me)
1047     !     ZNNT=1.
1048     !     CALL NNTPRT(AMXICE,LEN,ZNNT)
1049     !
1050             CRIT=0.5
1051             CALL ROF01(GLACIR,LEN,'GE',CRIT)
1052             CALL ROF01(AMXICE,LEN,'GE',CRIT)
1053     !
1054     !  Quality control max ice limit based on glacier points
1055     !
1056             CALL QCMXICE(GLACIR,AMXICE,LEN,me)
1057     !
1058           ENDIF                       ! First time loop finished
1059     !
1060           DO I=1,LEN
1061             SLICLM(I) = 1.
1062             SNOCLM(I) = 0.
1063             icefl1(i) = .true.
1064           ENDDO
1065     !     if(lprnt) print *,' tsffcsIN=',tsffcs(iprnt)
1066     !
1067     !  Read climatology fields
1068     !
1069           if (me .eq. 0) then
1070             WRITE(6,*) '=============='
1071             WRITE(6,*) 'CLIMATOLOGY'
1072             WRITE(6,*) '=============='
1073           endif
1074     !
1075           PERCRIT=CRITP1
1076     !
1077           CALL CLIMA(LUGB,IY,IM,ID,IH,FH,LEN,LSOIL,SLMASK,
1078          &           FNTSFC,FNWETC,FNSNOC,FNZORC,FNALBC,FNAISC,
1079          &           FNTG3C,FNSCVC,FNSMCC,FNSTCC,FNACNC,FNVEGC,
1080          &           fnvetc,fnsotc,
1081     !Clu [+1L] add fn()c for vmn, vmx, slp, abs
1082          &           FNVMNC,FNVMXC,FNSLPC,FNABSC,
1083          &           TSFCLM,TSFCL2,WETCLM,SNOCLM,ZORCLM,ALBCLM,AISCLM,
1084          &           TG3CLM,CVCLM ,CVBCLM,CVTCLM,
1085          &           CNPCLM,SMCCLM,STCCLM,SLICLM,SCVCLM,ACNCLM,VEGCLM,
1086          &           vetclm,sotclm,ALFCLM,
1087     !Clu [+1L] add ()clm for vmn, vmx, slp, abs
1088          &           VMNCLM,VMXCLM,SLPCLM,ABSCLM,
1089          &           KPDTSF,KPDWET,KPDSNO,KPDZOR,KPDALB,KPDAIS,
1090          &           KPDTG3,KPDSCV,KPDACN,KPDSMC,KPDSTC,KPDVEG,
1091          &           kpdvet,kpdsot,kpdalf,TSFCL0,
1092     !Clu [+1L] add kpd() for vmn, vmx, slp, abs
1093          &           KPDVMN,KPDVMX,KPDSLP,KPDABS,
1094          &           DELTSFC, LANOM
1095          &,          IMSK, JMSK, SLMSKH, RLA, RLO, GAUSM, BLNMSK, BLTMSK,me
1096          &,          lprnt, iprnt, FNALBC2, IALB)
1097     !     if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt)
1098     !
1099     !  Scale surface roughness and albedo to model required units
1100     !
1101           ZSCA=100.
1102           CALL SCALE(ZORCLM,LEN,ZSCA)
1103           ZSCA=0.01
1104           CALL SCALE(ALBCLM,LEN,ZSCA)
1105           CALL SCALE(ALBCLM(1,2),LEN,ZSCA)
1106           CALL SCALE(ALBCLM(1,3),LEN,ZSCA)
1107           CALL SCALE(ALBCLM(1,4),LEN,ZSCA)
1108           CALL SCALE(ALFCLM,LEN,ZSCA)
1109           CALL SCALE(ALFCLM(1,2),LEN,ZSCA)
1110     !Clu [+4L] scale vmn, vmx, abs from percent to fraction
1111           ZSCA=0.01
1112           CALL SCALE(VMNCLM,LEN,ZSCA)
1113           CALL SCALE(VMXCLM,LEN,ZSCA)
1114           CALL SCALE(ABSCLM,LEN,ZSCA)
1115     
1116     !
1117     !  Set albedo over ocean to ALBOMX
1118     !
1119           CALL ALBOCN(ALBCLM,SLMASK,ALBOMX,LEN)
1120     !
1121     !  make sure vegetation type and soil type are non zero over land
1122     !
1123     !Clu [-1L/+1L]: add slpclm
1124     !Clu  call landtyp(vetclm,sotclm,slmask,LEN)
1125           call landtyp(vetclm,sotclm,slpclm,slmask,LEN)
1126     !
1127     !Cwu [-1L/+1L]
1128     !* Ice concentration or ice mask (only ice mask used in the model now)
1129     !  Ice concentration and ice mask (both are used in the model now)
1130     !
1131           IF(FNAISC(1:8).NE.'        ') THEN
1132     !Cwu [+5L/-1L] Update SIHCLM, SICCLM
1133             DO I=1,LEN
1134              SIHCLM(I) = 3.0*AISCLM(I)
1135              SICCLM(I) = AISCLM(I)
1136               IF(SLMASK(I).EQ.0..AND.GLACIR(I).EQ.1..AND.
1137          &      SICCLM(I).NE.1.) THEN
1138                 SICCLM(I) = SICIMX
1139                 SIHFCS(I) = glacir_hice
1140               ENDIF
1141             ENDDO
1142             CRIT=AISLIM
1143     !*      CRIT=0.5
1144             CALL ROF01(AISCLM,LEN,'GE',CRIT)
1145           ELSEIF(FNACNC(1:8).NE.'        ') THEN
1146     !Cwu [+4L] Update SIHCLM, SICCLM
1147             DO I=1,LEN
1148              SIHCLM(I) = 3.0*ACNCLM(I)
1149              SICCLM(I) = ACNCLM(I)
1150               IF(SLMASK(I).EQ.0..AND.GLACIR(I).EQ.1..AND.
1151          &      SICCLM(I).NE.1.) THEN
1152                 SICCLM(I) = SICIMX
1153                 SIHFCS(I) = glacir_hice
1154               ENDIF
1155             ENDDO
1156             CALL ROF01(ACNCLM,LEN,'GE',AISLIM)
1157             DO I=1,LEN
1158              AISCLM(I) = ACNCLM(I)
1159             ENDDO
1160           ENDIF
1161     !
1162     !  Quality control of sea ice mask
1163     !
1164           CALL QCSICE(AISCLM,GLACIR,AMXICE,AICICE,AICSEA,SLLND,SLMASK,
1165          &            RLA,RLO,LEN,me)
1166     !
1167     !  Set ocean/land/sea-ice mask
1168     !
1169           CALL SETLSI(SLMASK,AISCLM,LEN,AICICE,SLICLM)
1170     !     if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm='
1171     !    *,sliclm(iprnt),' slmask=',slmask(iprnt)
1172     !
1173     !     WRITE(6,*) 'SLICLM'
1174     !     ZNNT=1.
1175     !     CALL NNTPRT(SLICLM,LEN,ZNNT)
1176     !
1177     !  Quality control of snow
1178     !
1179     !cggg landice mods start
1180     !       CALL QCSNOW(SNOCLM,SLMASK,AISCLM,GLACIR,LEN,SNOSMX,me)
1181            CALL QCSNOW(SNOCLM,SLMASK,AISCLM,GLACIR,LEN,SNOSMX,LANDICE,me)
1182     !cggg landice mods end
1183     !
1184           CALL SETZRO(SNOCLM,EPSSNO,LEN)
1185     !
1186     !  Snow cover handling (We assume climatological snow depth is available)
1187     !  Quality control of snow depth (Note that Snow should be corrected first
1188     !  because it influences TSF
1189     !
1190           KQCM=1
1191           CALL QCMXMN('Snow    ',SNOCLM,SLICLM,SNOCLM,icefl1,
1192          &            SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
1193          &            SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
1194          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1195     !     WRITE(6,*) 'SNOCLM'
1196     !     ZNNT=1.
1197     !     CALL NNTPRT(SNOCLM,LEN,ZNNT)
1198     !
1199     !  Get snow cover from snow depth array
1200     !
1201           IF(FNSCVC(1:8).EQ.'        ') THEN
1202             CALL GETSCV(SNOCLM,SCVCLM,LEN)
1203           ENDIF
1204     !
1205     !  Set TSFC over snow to TSFSMX if greater
1206     !
1207           CALL SNOSFC(SNOCLM,TSFCLM,TSFSMX,LEN,me)
1208     !     CALL SNOSFC(SNOCLM,TSFCL2,TSFSMX,LEN)
1209     !
1210     !  Quality control
1211     !
1212           do i=1,len
1213             icefl2(i) = sicclm(i) .gt. 0.99999
1214           enddo
1215           KQCM=1
1216           CALL QCMXMN('TSFc    ',TSFCLM,SLICLM,SNOCLM,icefl2,
1217          &            TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
1218          &            TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
1219          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1220           CALL QCMXMN('TSf2    ',TSFCL2,SLICLM,SNOCLM,icefl2,
1221          &            TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
1222          &            TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
1223          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1224           do kk = 1, 4
1225           CALL QCMXMN('ALBc    ',ALBCLM(1,kk),SLICLM,SNOCLM,icefl1,
1226          &            ALBLMX,ALBLMN,ALBOMX,ALBOMN,ALBIMX,ALBIMN,
1227          &            ALBJMX,ALBJMN,ALBSMX,ALBSMN,EPSALB,
1228          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1229           enddo
1230           IF(FNWETC(1:8).NE.'        ') THEN
1231             CALL QCMXMN('WETc    ',WETCLM,SLICLM,SNOCLM,icefl1,
1232          &              WETLMX,WETLMN,WETOMX,WETOMN,WETIMX,WETIMN,
1233          &              WETJMX,WETJMN,WETSMX,WETSMN,EPSWET,
1234          &              RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1235           ENDIF
1236           CALL QCMXMN('ZORc    ',ZORCLM,SLICLM,SNOCLM,icefl1,
1237          &            ZORLMX,ZORLMN,ZOROMX,ZOROMN,ZORIMX,ZORIMN,
1238          &            ZORJMX,ZORJMN,ZORSMX,ZORSMN,EPSZOR,
1239          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1240     !     IF(FNPLRC(1:8).NE.'        ') THEN
1241     !     CALL QCMXMN('PLNTc   ',PLRCLM,SLICLM,SNOCLM,icefl1,
1242     !    &            PLRLMX,PLRLMN,PLROMX,PLROMN,PLRIMX,PLRIMN,
1243     !    &            PLRJMX,PLRJMN,PLRSMX,PLRSMN,EPSPLR,
1244     !    &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1245     !     ENDIF
1246           CALL QCMXMN('TG3c    ',TG3CLM,SLICLM,SNOCLM,icefl1,
1247          &            TG3LMX,TG3LMN,TG3OMX,TG3OMN,TG3IMX,TG3IMN,
1248          &            TG3JMX,TG3JMN,TG3SMX,TG3SMN,EPSTG3,
1249          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1250     !
1251     !  Get soil temp and moisture (after all the QCs are completed)
1252     !
1253           IF(FNSMCC(1:8).EQ.'        ') THEN
1254             CALL GETSMC(WETCLM,LEN,LSOIL,SMCCLM,me)
1255           ENDIF
1256           CALL QCMXMN('SMC1c   ',SMCCLM(1,1),SLICLM,SNOCLM,icefl1,
1257          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1258          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1259          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1260           CALL QCMXMN('SMC2c   ',SMCCLM(1,2),SLICLM,SNOCLM,icefl1,
1261          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1262          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1263          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1264     !Clu [+8L] add smcclm(3:4)
1265           IF(LSOIL.GT.2) THEN
1266           CALL QCMXMN('SMC3c   ',SMCCLM(1,3),SLICLM,SNOCLM,icefl1,
1267          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1268          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1269          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1270           CALL QCMXMN('SMC4c   ',SMCCLM(1,4),SLICLM,SNOCLM,icefl1,
1271          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1272          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1273          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1274           ENDIF
1275           IF(FNSTCC(1:8).EQ.'        ') THEN
1276             CALL GETSTC(TSFCLM,TG3CLM,SLICLM,LEN,LSOIL,STCCLM,TSFIMX)
1277           ENDIF
1278           CALL QCMXMN('STC1c   ',STCCLM(1,1),SLICLM,SNOCLM,icefl1,
1279          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1280          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1281          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1282           CALL QCMXMN('STC2c   ',STCCLM(1,2),SLICLM,SNOCLM,icefl1,
1283          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1284          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1285          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1286     !Clu [+8L] add stcclm(3:4)
1287           IF(LSOIL.GT.2) THEN
1288           CALL QCMXMN('STC3c   ',STCCLM(1,3),SLICLM,SNOCLM,icefl1,
1289          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1290          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1291          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1292           CALL QCMXMN('STC4c   ',STCCLM(1,4),SLICLM,SNOCLM,icefl1,
1293          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1294          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1295          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1296           ENDIF
1297           CALL QCMXMN('VEGc    ',VEGCLM,SLICLM,SNOCLM,icefl1,
1298          &            VEGLMX,VEGLMN,VEGOMX,VEGOMN,VEGIMX,VEGIMN,
1299          &            VEGJMX,VEGJMN,VEGSMX,VEGSMN,EPSVEG,
1300          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1301           CALL QCMXMN('VETc    ',VETCLM,SLICLM,SNOCLM,icefl1,
1302          &            VETLMX,VETLMN,VETOMX,VETOMN,VETIMX,VETIMN,
1303          &            VETJMX,VETJMN,VETSMX,VETSMN,EPSVET,
1304          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1305           CALL QCMXMN('SOTc    ',SOTCLM,SLICLM,SNOCLM,icefl1,
1306          &            SOTLMX,SOTLMN,SOTOMX,SOTOMN,SOTIMX,SOTIMN,
1307          &            SOTJMX,SOTJMN,SOTSMX,SOTSMN,EPSSOT,
1308          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1309     !Cwu [+8L] ---------------------------------------------------------------
1310           CALL QCMXMN('SIHc    ',SIHCLM,SLICLM,SNOCLM,icefl1,
1311          &            SIHLMX,SIHLMN,SIHOMX,SIHOMN,SIHIMX,SIHIMN,
1312          &            SIHJMX,SIHJMN,SIHSMX,SIHSMN,EPSSIH,
1313          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1314           CALL QCMXMN('SICc    ',SICCLM,SLICLM,SNOCLM,icefl1,
1315          &            SICLMX,SICLMN,SICOMX,SICOMN,SICIMX,SICIMN,
1316          &            SICJMX,SICJMN,SICSMX,SICSMN,EPSSIC,
1317          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1318     !Clu [+16L] ---------------------------------------------------------------
1319           CALL QCMXMN('VMNc    ',VMNCLM,SLICLM,SNOCLM,icefl1,
1320          &            VMNLMX,VMNLMN,VMNOMX,VMNOMN,VMNIMX,VMNIMN,
1321          &            VMNJMX,VMNJMN,VMNSMX,VMNSMN,EPSVMN,
1322          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1323           CALL QCMXMN('VMXc    ',VMXCLM,SLICLM,SNOCLM,icefl1,
1324          &            VMXLMX,VMXLMN,VMXOMX,VMXOMN,VMXIMX,VMXIMN,
1325          &            VMXJMX,VMXJMN,VMXSMX,VMXSMN,EPSVMX,
1326          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1327           CALL QCMXMN('SLPc    ',SLPCLM,SLICLM,SNOCLM,icefl1,
1328          &            SLPLMX,SLPLMN,SLPOMX,SLPOMN,SLPIMX,SLPIMN,
1329          &            SLPJMX,SLPJMN,SLPSMX,SLPSMN,EPSSLP,
1330          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1331           CALL QCMXMN('ABSc    ',ABSCLM,SLICLM,SNOCLM,icefl1,
1332          &            ABSLMX,ABSLMN,ABSOMX,ABSOMN,ABSIMX,ABSIMN,
1333          &            ABSJMX,ABSJMN,ABSSMX,ABSSMN,EPSABS,
1334          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1335     !Clu ----------------------------------------------------------------------
1336     !
1337     !  MONITORING PRINTS
1338     !
1339           IF (MONCLM) THEN
1340            if (me .eq. 0) then
1341             PRINT *,' '
1342             PRINT *,'MONITOR OF TIME AND SPACE INTERPOLATED CLIMATOLOGY'
1343             PRINT *,' '
1344     !       CALL COUNT(SLICLM,SNOCLM,LEN)
1345             PRINT *,' '
1346             CALL MONITR('TSFCLM',TSFCLM,SLICLM,SNOCLM,LEN)
1347             CALL MONITR('ALBCLM',ALBCLM(1,1),SLICLM,SNOCLM,LEN)
1348             CALL MONITR('ALBCLM',ALBCLM(1,2),SLICLM,SNOCLM,LEN)
1349             CALL MONITR('ALBCLM',ALBCLM(1,3),SLICLM,SNOCLM,LEN)
1350             CALL MONITR('ALBCLM',ALBCLM(1,4),SLICLM,SNOCLM,LEN)
1351             CALL MONITR('AISCLM',AISCLM,SLICLM,SNOCLM,LEN)
1352             CALL MONITR('SNOCLM',SNOCLM,SLICLM,SNOCLM,LEN)
1353             CALL MONITR('SCVCLM',SCVCLM,SLICLM,SNOCLM,LEN)
1354             CALL MONITR('SMCCLM1',SMCCLM(1,1),SLICLM,SNOCLM,LEN)
1355             CALL MONITR('SMCCLM2',SMCCLM(1,2),SLICLM,SNOCLM,LEN)
1356             CALL MONITR('STCCLM1',STCCLM(1,1),SLICLM,SNOCLM,LEN)
1357             CALL MONITR('STCCLM2',STCCLM(1,2),SLICLM,SNOCLM,LEN)
1358     !Clu [+4L] add smcclm(3:4) and stcclm(3:4)
1359             IF(LSOIL.GT.2) THEN
1360             CALL MONITR('SMCCLM3',SMCCLM(1,3),SLICLM,SNOCLM,LEN)
1361             CALL MONITR('SMCCLM4',SMCCLM(1,4),SLICLM,SNOCLM,LEN)
1362             CALL MONITR('STCCLM3',STCCLM(1,3),SLICLM,SNOCLM,LEN)
1363             CALL MONITR('STCCLM4',STCCLM(1,4),SLICLM,SNOCLM,LEN)
1364             ENDIF
1365             CALL MONITR('TG3CLM',TG3CLM,SLICLM,SNOCLM,LEN)
1366             CALL MONITR('ZORCLM',ZORCLM,SLICLM,SNOCLM,LEN)
1367     !       IF (GAUS) THEN
1368               CALL MONITR('CVACLM',CVCLM ,SLICLM,SNOCLM,LEN)
1369               CALL MONITR('CVBCLM',CVBCLM,SLICLM,SNOCLM,LEN)
1370               CALL MONITR('CVTCLM',CVTCLM,SLICLM,SNOCLM,LEN)
1371     !       ENDIF
1372             CALL MONITR('SLICLM',SLICLM,SLICLM,SNOCLM,LEN)
1373     !       CALL MONITR('PLRCLM',PLRCLM,SLICLM,SNOCLM,LEN)
1374             CALL MONITR('OROG  ',OROG  ,SLICLM,SNOCLM,LEN)
1375             CALL MONITR('VEGCLM',VEGCLM,SLICLM,SNOCLM,LEN)
1376             CALL MONITR('VETCLM',VETCLM,SLICLM,SNOCLM,LEN)
1377             CALL MONITR('SOTCLM',SOTCLM,SLICLM,SNOCLM,LEN)
1378     !Cwu [+2L] add sih, sic
1379             CALL MONITR('SIHCLM',SIHCLM,SLICLM,SNOCLM,LEN)
1380             CALL MONITR('SICCLM',SICCLM,SLICLM,SNOCLM,LEN)
1381     !Clu [+4L] add vmn, vmx, slp, abs
1382             CALL MONITR('VMNCLM',VMNCLM,SLICLM,SNOCLM,LEN)
1383             CALL MONITR('VMXCLM',VMXCLM,SLICLM,SNOCLM,LEN)
1384             CALL MONITR('SLPCLM',SLPCLM,SLICLM,SNOCLM,LEN)
1385             CALL MONITR('ABSCLM',ABSCLM,SLICLM,SNOCLM,LEN)
1386            endif
1387           ENDIF
1388     !
1389     !
1390           if (me .eq. 0) then
1391             WRITE(6,*) '=============='
1392             WRITE(6,*) '   ANALYSIS'
1393             WRITE(6,*) '=============='
1394           endif
1395     !
1396     !  Fill in analysis array with climatology before reading analysis.
1397     !
1398           CALL FILANL(TSFANL,TSFAN2,WETANL,SNOANL,ZORANL,ALBANL,AISANL,
1399          &            TG3ANL,CVANL ,CVBANL,CVTANL,
1400          &            CNPANL,SMCANL,STCANL,SLIANL,SCVANL,VEGANL,
1401          &            vetanl,sotanl,ALFANL,
1402     !Cwu [+1L] add ()anl for sih, sic
1403          &            SIHANL,SICANL,
1404     !Clu [+1L] add ()anl for vmn, vmx, slp, abs
1405          &            VMNANL,VMXANL,SLPANL,ABSANL, 
1406          &            TSFCLM,TSFCL2,WETCLM,SNOCLM,ZORCLM,ALBCLM,AISCLM,
1407          &            TG3CLM,CVCLM ,CVBCLM,CVTCLM,
1408          &            CNPCLM,SMCCLM,STCCLM,SLICLM,SCVCLM,VEGCLM,
1409          &            vetclm,sotclm,ALFCLM,
1410     !Cwu [+1L] add ()clm for sih, sic
1411          &            SIHCLM,SICCLM,
1412     !Clu [+1L] add ()clm for vmn, vmx, slp, abs
1413          &            VMNCLM,VMXCLM,SLPCLM,ABSCLM,      
1414          &            LEN,LSOIL)
1415     !
1416     !  Reverse scaling to match with grib analysis input
1417     !
1418           ZSCA=0.01
1419           CALL SCALE(ZORANL,LEN, ZSCA)
1420           ZSCA=100.
1421           CALL SCALE(ALBANL,LEN,ZSCA)
1422           CALL SCALE(ALBANL(1,2),LEN,ZSCA)
1423           CALL SCALE(ALBANL(1,3),LEN,ZSCA)
1424           CALL SCALE(ALBANL(1,4),LEN,ZSCA)
1425           CALL SCALE(ALFANL,LEN,ZSCA)
1426           CALL SCALE(ALFANL(1,2),LEN,ZSCA)
1427     !Clu [+4L] reverse scale for vmn, vmx, abs
1428           ZSCA=100.
1429           CALL SCALE(VMNANL,LEN,ZSCA)
1430           CALL SCALE(VMXANL,LEN,ZSCA)
1431           CALL SCALE(ABSANL,LEN,ZSCA)
1432     !
1433           PERCRIT=CRITP2
1434     !
1435     !  READ ANALYSIS FIELDS
1436     !
1437           CALL ANALY(LUGB,IY,IM,ID,IH,FH,LEN,LSOIL,SLMASK,
1438          &           FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
1439          &           FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,FNVEGA,
1440          &           fnveta,fnsota,
1441     !Clu [+1L] add fn()a for vmn, vmx, slp, abs
1442          &           FNVMNA,FNVMXA,FNSLPA,FNABSA,      
1443          &           TSFANL,WETANL,SNOANL,ZORANL,ALBANL,AISANL,
1444          &           TG3ANL,CVANL ,CVBANL,CVTANL,
1445          &           SMCANL,STCANL,SLIANL,SCVANL,ACNANL,VEGANL,
1446          &           vetanl,sotanl,ALFANL,TSFAN0,
1447     !Clu [+1L] add ()anl for vmn, vmx, slp, abs
1448          &           VMNANL,VMXANL,SLPANL,ABSANL,      
1449     !cggg snow mods start     &   KPDTSF,KPDWET,KPDSNO,KPDZOR,KPDALB,KPDAIS,
1450          &           KPDTSF,KPDWET,KPDSNO,KPDSND,KPDZOR,KPDALB,KPDAIS,
1451     !cggg snow mods end
1452          &           KPDTG3,KPDSCV,KPDACN,KPDSMC,KPDSTC,KPDVEG,
1453          &           kpdvet,kpdsot,kpdalf,
1454     !Clu [+1L] add kpd() for vmn, vmx, slp, abs
1455          &           KPDVMN,KPDVMX,KPDSLP,KPDABS,      
1456          &           IRTTSF,IRTWET,IRTSNO,IRTZOR,IRTALB,IRTAIS,
1457          &           IRTTG3,IRTSCV,IRTACN,IRTSMC,IRTSTC,IRTVEG,
1458          &           irtvet,irtsot,irtalf
1459     !Clu [+1L] add irt() for vmn, vmx, slp, abs
1460          &,          IRTVMN,IRTVMX,IRTSLP,IRTABS, 
1461          &           IMSK, JMSK, SLMSKH, RLA, RLO, GAUSM, BLNMSK, BLTMSK,me)
1462     !     if(lprnt) print *,' tsfanl=',tsfanl(iprnt)
1463     !
1464     !  Scale ZOR and ALB to match forecast model units
1465     !
1466           ZSCA=100.
1467           CALL SCALE(ZORANL,LEN, ZSCA)
1468           ZSCA=0.01
1469           CALL SCALE(ALBANL,LEN,ZSCA)
1470           CALL SCALE(ALBANL(1,2),LEN,ZSCA)
1471           CALL SCALE(ALBANL(1,3),LEN,ZSCA)
1472           CALL SCALE(ALBANL(1,4),LEN,ZSCA)
1473           CALL SCALE(ALFANL,LEN,ZSCA)
1474           CALL SCALE(ALFANL(1,2),LEN,ZSCA)
1475     !Clu [+4] scale vmn, vmx, abs from percent to fraction
1476           ZSCA=0.01
1477           CALL SCALE(VMNANL,LEN,ZSCA)
1478           CALL SCALE(VMXANL,LEN,ZSCA)
1479           CALL SCALE(ABSANL,LEN,ZSCA)
1480     !
1481     !  Interpolate climatology but fixing initial anomaly
1482     !
1483           IF(FH.GT.0.0.AND.FNTSFA(1:8).NE.'        '.AND.LANOM) THEN
1484             CALL ANOMINT(TSFAN0,TSFCLM,TSFCL0,TSFANL,LEN)
1485           ENDIF
1486     !
1487     !  Ice concentration or ice mask (only ice mask used in the model now)
1488     !
1489           IF(FNAISA(1:8).NE.'        ') THEN
1490     !Cwu [+5L/-1L] Update SIHANL, SICANL
1491             DO I=1,LEN
1492              SIHANL(I) = 3.0*AISANL(I)
1493              SICANL(I) = AISANL(I)
1494               IF(SLMASK(I).EQ.0..AND.GLACIR(I).EQ.1..AND.
1495          &      SICANL(I).NE.1.) THEN
1496                 SICANL(I) = SICIMX
1497                 SIHFCS(I) = glacir_hice
1498               ENDIF
1499             ENDDO
1500             CRIT=AISLIM
1501     !*      CRIT=0.5
1502             CALL ROF01(AISANL,LEN,'GE',CRIT)
1503           ELSEIF(FNACNA(1:8).NE.'        ') THEN
1504     !Cwu [+17L] update SIHANL, SICANL
1505             DO I=1,LEN
1506               SIHANL(I) = 3.0*ACNANL(I)
1507               SICANL(I) = ACNANL(I)
1508               IF(SLMASK(I).EQ.0..AND.GLACIR(I).EQ.1..AND.
1509          &     SICANL(I).NE.1.) THEN
1510                 SICANL(I) = SICIMX
1511                 SIHFCS(I) = glacir_hice
1512               ENDIF
1513             ENDDO
1514             CRIT=AISLIM
1515             DO I=1,LEN
1516               IF((SLIANL(I).EQ.0.).AND.(SICANL(I).GE.CRIT)) THEN
1517                 SLIANL(I)=2.
1518     !           PRINT *,'cycle - NEW ICE FORM: FICE=',SICANL(I)
1519               ELSE IF((SLIANL(I).GE.2.).AND.(SICANL(I).LT.CRIT)) THEN
1520                 SLIANL(I)=0.
1521     !           PRINT *,'cycle - ICE FREE: FICE=',SICANL(I)
1522               ELSE IF((SLIANL(I).EQ.1.).AND.(SICANL(I).GE.SICIMN)) THEN
1523     !           PRINT *,'cycle - LAND COVERED BY SEA-ICE: FICE=',SICANL(I)
1524                 SICANL(I)=0.
1525               ENDIF
1526             ENDDO
1527     !       ZNNT=10.
1528     !       CALL NNTPRT(ACNANL,LEN,ZNNT)
1529     !     if(lprnt) print *,' acnanl=',acnanl(iprnt)
1530     !       DO I=1,LEN
1531     !         if (ACNANL(I) .GT. 0.3 .AND. AISCLM(I) .EQ. 1.0
1532     !    &     .AND. AISFCS(I) .GE. 0.75)   ACNANL(I) = AISLIM
1533     !       ENDDO
1534     !     if(lprnt) print *,' acnanl=',acnanl(iprnt)
1535             CALL ROF01(ACNANL,LEN,'GE',AISLIM)
1536             DO I=1,LEN
1537               AISANL(I)=ACNANL(I)
1538             ENDDO
1539           ENDIF
1540     !     if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir='
1541     !    &,glacir(iprnt),' slmask=',slmask(iprnt)
1542     !
1543           CALL QCSICE(AISANL,GLACIR,AMXICE,AICICE,AICSEA,SLLND,SLMASK,
1544          &            RLA,RLO,LEN,me)
1545     !
1546     !  Set ocean/land/sea-ice mask
1547     !
1548           CALL SETLSI(SLMASK,AISANL,LEN,AICICE,SLIANL)
1549     !     if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl='
1550     !    *,slianl(iprnt),' slmask=',slmask(iprnt)
1551     !
1552     !
1553           do k=1,lsoil
1554             do i=1,len
1555               if (slianl(i) .eq. 0) then
1556                 smcanl(i,k) = smcomx
1557                 stcanl(i,k) = tsfanl(i)
1558               endif
1559             enddo
1560           enddo
1561     
1562     !     WRITE(6,*) 'SLIANL'
1563     !     ZNNT=1.
1564     !     CALL NNTPRT(SLIANL,LEN,ZNNT)
1565     !Cwu [+8L]----------------------------------------------------------------------
1566           CALL QCMXMN('SIHa    ',SIHANL,SLIANL,SNOANL,icefl1,
1567          &            SIHLMX,SIHLMN,SIHOMX,SIHOMN,SIHIMX,SIHIMN,
1568          &            SIHJMX,SIHJMN,SIHSMX,SIHSMN,EPSSIH,
1569          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1570           CALL QCMXMN('SICa    ',SICANL,SLIANL,SNOANL,icefl1,
1571          &            SICLMX,SICLMN,SICOMX,SICOMN,SICIMX,SICIMN,
1572          &            SICJMX,SICJMN,SICSMX,SICSMN,EPSSIC,
1573          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1574     !
1575     !  Set albedo over ocean to ALBOMX
1576     !
1577           CALL ALBOCN(ALBANL,SLMASK,ALBOMX,LEN)
1578     !
1579     !  Quality control of snow and sea-ice
1580     !    Process snow depth or snow cover
1581     !
1582           IF(FNSNOA(1:8).NE.'        ') THEN
1583             CALL SETZRO(SNOANL,EPSSNO,LEN)
1584     !cggg landice mods start
1585     !         CALL QCSNOW(SNOANL,SLMASK,AISANL,GLACIR,LEN,10.,me)
1586              CALL QCSNOW(SNOANL,SLMASK,AISANL,GLACIR,LEN,ten,LANDICE,me)
1587     !cggg landice mods end
1588     !cggg landice mods start
1589     !       CALL SNODPTH2(GLACIR,SNOSMX,SNOANL, LEN, me)
1590             IF (.NOT.LANDICE) THEN
1591               CALL SNODPTH2(GLACIR,SNOSMX,SNOANL, LEN, me)
1592             ENDIF
1593     !cggg landice mods end
1594             KQCM=1
1595             CALL SNOSFC(SNOANL,TSFANL,TSFSMX,LEN,me)
1596             CALL QCMXMN('Snoa    ',SNOANL,SLIANL,SNOANL,icefl1,
1597          &              SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
1598          &              SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
1599          &              RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1600             CALL GETSCV(SNOANL,SCVANL,LEN)
1601             CALL QCMXMN('Sncva'   ,SCVANL,SLIANL,SNOANL,icefl1,
1602          &              SCVLMX,SCVLMN,SCVOMX,SCVOMN,SCVIMX,SCVIMN,
1603          &              SCVJMX,SCVJMN,SCVSMX,SCVSMN,EPSSCV,
1604          &              RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1605           ELSE
1606             CRIT=0.5
1607             CALL ROF01(SCVANL,LEN,'GE',CRIT)
1608     !cggg landice mods start
1609     !        CALL QCSNOW(SCVANL,SLMASK,AISANL,GLACIR,LEN,1.,me)
1610             CALL QCSNOW(SCVANL,SLMASK,AISANL,GLACIR,LEN,one,LANDICE,me)
1611     !cggg landice mods end
1612             CALL QCMXMN('SNcva   ',SCVANL,SLIANL,SCVANL,icefl1,
1613          &              SCVLMX,SCVLMN,SCVOMX,SCVOMN,SCVIMX,SCVIMN,
1614          &              SCVJMX,SCVJMN,SCVSMX,SCVSMN,EPSSCV,
1615          &              RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1616     !cggg landice mods start
1617     !        CALL SNODPTH(SCVANL,SLIANL,TSFANL,SNOCLM,
1618     !     &               GLACIR,SNWMAX,SNWMIN,LEN,SNOANL,me)
1619             CALL SNODPTH(SCVANL,SLIANL,TSFANL,SNOCLM,
1620          &               GLACIR,SNWMAX,SNWMIN,LANDICE,LEN,SNOANL,me)
1621     !cggg landice mods end
1622     !cggg landice mods start
1623     !        CALL QCSNOW(SCVANL,SLMASK,AISANL,GLACIR,LEN,SNOSMX,me)
1624             CALL QCSNOW(SCVANL,SLMASK,AISANL,GLACIR,LEN,SNOSMX,LANDICE,me)
1625     !cggg landice mods end
1626             CALL SNOSFC(SNOANL,TSFANL,TSFSMX,LEN,me)
1627             CALL QCMXMN('SNowa   ',SNOANL,SLIANL,SNOANL,icefl1,
1628          &              SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
1629          &              SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
1630          &              RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1631           ENDIF
1632     !
1633           do i=1,len
1634             icefl2(i) = sicanl(i) .gt. 0.99999
1635           enddo
1636           CALL QCMXMN('TSFa    ',TSFANL,SLIANL,SNOANL,icefl2,
1637          &            TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
1638          &            TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
1639          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1640           do kk = 1, 4
1641           CALL QCMXMN('ALBa    ',ALBANL(1,kk),SLIANL,SNOANL,icefl1,
1642          &            ALBLMX,ALBLMN,ALBOMX,ALBOMN,ALBIMX,ALBIMN,
1643          &            ALBJMX,ALBJMN,ALBSMX,ALBSMN,EPSALB,
1644          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1645           enddo
1646           IF(FNWETC(1:8).NE.'        ' .OR. FNWETA(1:8).NE.'        ' ) THEN
1647           CALL QCMXMN('WETa    ',WETANL,SLIANL,SNOANL,icefl1,
1648          &            WETLMX,WETLMN,WETOMX,WETOMN,WETIMX,WETIMN,
1649          &            WETJMX,WETJMN,WETSMX,WETSMN,EPSWET,
1650          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1651           ENDIF
1652           CALL QCMXMN('ZORa    ',ZORANL,SLIANL,SNOANL,icefl1,
1653          &            ZORLMX,ZORLMN,ZOROMX,ZOROMN,ZORIMX,ZORIMN,
1654          &            ZORJMX,ZORJMN,ZORSMX,ZORSMN,EPSZOR,
1655          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1656     !     IF(FNPLRC(1:8).NE.'        ' .OR. FNPLRA(1:8).NE.'        ' ) THEN
1657     !     CALL QCMXMN('PLNa    ',PLRANL,SLIANL,SNOANL,icefl1,
1658     !    &            PLRLMX,PLRLMN,PLROMX,PLROMN,PLRIMX,PLRIMN,
1659     !    &            PLRJMX,PLRJMN,PLRSMX,PLRSMN,EPSPLR,
1660     !    &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1661     !     ENDIF
1662           CALL QCMXMN('TG3a    ',TG3ANL,SLIANL,SNOANL,icefl1,
1663          &            TG3LMX,TG3LMN,TG3OMX,TG3OMN,TG3IMX,TG3IMN,
1664          &            TG3JMX,TG3JMN,TG3SMX,TG3SMN,EPSTG3,
1665          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1666     !
1667     !  Get soil temp and moisture
1668     !
1669           IF(FNSMCA(1:8).EQ.'        ' .AND. FNSMCC(1:8).EQ.'        ') THEN
1670             CALL GETSMC(WETANL,LEN,LSOIL,SMCANL,me)
1671           ENDIF
1672           CALL QCMXMN('SMC1a   ',SMCANL(1,1),SLIANL,SNOANL,icefl1,
1673          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1674          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1675          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1676           CALL QCMXMN('SMC2a   ',SMCANL(1,2),SLIANL,SNOANL,icefl1,
1677          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1678          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1679          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1680     !Clu [+8L] add smcanl(3:4)
1681           IF(LSOIL.GT.2) THEN
1682           CALL QCMXMN('SMC3a   ',SMCANL(1,3),SLIANL,SNOANL,icefl1,
1683          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1684          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1685          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1686           CALL QCMXMN('SMC4a   ',SMCANL(1,4),SLIANL,SNOANL,icefl1,
1687          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1688          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1689          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1690           ENDIF
1691           IF(FNSTCA(1:8).EQ.'        ') THEN
1692             CALL GETSTC(TSFANL,TG3ANL,SLIANL,LEN,LSOIL,STCANL,TSFIMX)
1693           ENDIF
1694           CALL QCMXMN('STC1a   ',STCANL(1,1),SLIANL,SNOANL,icefl1,
1695          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1696          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1697          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1698           CALL QCMXMN('STC2a   ',STCANL(1,2),SLIANL,SNOANL,icefl1,
1699          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1700          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1701          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1702     !Clu [+8L] add stcanl(3:4)
1703           IF(LSOIL.GT.2) THEN
1704           CALL QCMXMN('STC3a   ',STCANL(1,3),SLIANL,SNOANL,icefl1,
1705          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1706          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1707          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1708           CALL QCMXMN('STC4a   ',STCANL(1,4),SLIANL,SNOANL,icefl1,
1709          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1710          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1711          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1712           ENDIF
1713           CALL QCMXMN('VEGa    ',VEGANL,SLIANL,SNOANL,icefl1,
1714          &            VEGLMX,VEGLMN,VEGOMX,VEGOMN,VEGIMX,VEGIMN,
1715          &            VEGJMX,VEGJMN,VEGSMX,VEGSMN,EPSVEG,
1716          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1717           CALL QCMXMN('VETa    ',VETANL,SLIANL,SNOANL,icefl1,
1718          &            VETLMX,VETLMN,VETOMX,VETOMN,VETIMX,VETIMN,
1719          &            VETJMX,VETJMN,VETSMX,VETSMN,EPSVET,
1720          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1721           CALL QCMXMN('SOTa    ',SOTANL,SLIANL,SNOANL,icefl1,
1722          &            SOTLMX,SOTLMN,SOTOMX,SOTOMN,SOTIMX,SOTIMN,
1723          &            SOTJMX,SOTJMN,SOTSMX,SOTSMN,EPSSOT,
1724          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1725     !Clu [+16L]----------------------------------------------------------------------
1726           CALL QCMXMN('VMNa    ',VMNANL,SLIANL,SNOANL,icefl1,
1727          &            VMNLMX,VMNLMN,VMNOMX,VMNOMN,VMNIMX,VMNIMN,
1728          &            VMNJMX,VMNJMN,VMNSMX,VMNSMN,EPSVMN,
1729          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1730           CALL QCMXMN('VMXa    ',VMXANL,SLIANL,SNOANL,icefl1,
1731          &            VMXLMX,VMXLMN,VMXOMX,VMXOMN,VMXIMX,VMXIMN,
1732          &            VMXJMX,VMXJMN,VMXSMX,VMXSMN,EPSVMX,
1733          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1734           CALL QCMXMN('SLPa    ',SLPANL,SLIANL,SNOANL,icefl1,
1735          &            SLPLMX,SLPLMN,SLPOMX,SLPOMN,SLPIMX,SLPIMN,
1736          &            SLPJMX,SLPJMN,SLPSMX,SLPSMN,EPSSLP,
1737          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1738           CALL QCMXMN('ABSa    ',ABSANL,SLIANL,SNOANL,icefl1,
1739          &            ABSLMX,ABSLMN,ABSOMX,ABSOMN,ABSIMX,ABSIMN,
1740          &            ABSJMX,ABSJMN,ABSSMX,ABSSMN,EPSABS,
1741          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1742     !Clu ----------------------------------------------------------------------------
1743     !
1744     !  MONITORING PRINTS
1745     !
1746           IF (MONANL) THEN
1747            if (me .eq. 0) then
1748             PRINT *,' '
1749             PRINT *,'MONITOR OF TIME AND SPACE INTERPOLATED ANALYSIS'
1750             PRINT *,' '
1751     !       CALL COUNT(SLIANL,SNOANL,LEN)
1752             PRINT *,' '
1753             CALL MONITR('TSFANL',TSFANL,SLIANL,SNOANL,LEN)
1754             CALL MONITR('ALBANL',ALBANL,SLIANL,SNOANL,LEN)
1755             CALL MONITR('AISANL',AISANL,SLIANL,SNOANL,LEN)
1756             CALL MONITR('SNOANL',SNOANL,SLIANL,SNOANL,LEN)
1757             CALL MONITR('SCVANL',SCVANL,SLIANL,SNOANL,LEN)
1758             CALL MONITR('SMCANL1',SMCANL(1,1),SLIANL,SNOANL,LEN)
1759             CALL MONITR('SMCANL2',SMCANL(1,2),SLIANL,SNOANL,LEN)
1760             CALL MONITR('STCANL1',STCANL(1,1),SLIANL,SNOANL,LEN)
1761             CALL MONITR('STCANL2',STCANL(1,2),SLIANL,SNOANL,LEN)
1762     !Clu [+4L] add smcanl(3:4) and stcanl(3:4)
1763             IF(LSOIL.GT.2) THEN
1764             CALL MONITR('SMCANL3',SMCANL(1,3),SLIANL,SNOANL,LEN)
1765             CALL MONITR('SMCANL4',SMCANL(1,4),SLIANL,SNOANL,LEN)
1766             CALL MONITR('STCANL3',STCANL(1,3),SLIANL,SNOANL,LEN)
1767             CALL MONITR('STCANL4',STCANL(1,4),SLIANL,SNOANL,LEN)
1768             ENDIF
1769             CALL MONITR('TG3ANL',TG3ANL,SLIANL,SNOANL,LEN)
1770             CALL MONITR('ZORANL',ZORANL,SLIANL,SNOANL,LEN)
1771     !       IF (GAUS) THEN
1772               CALL MONITR('CVAANL',CVANL ,SLIANL,SNOANL,LEN)
1773               CALL MONITR('CVBANL',CVBANL,SLIANL,SNOANL,LEN)
1774               CALL MONITR('CVTANL',CVTANL,SLIANL,SNOANL,LEN)
1775     !       ENDIF
1776             CALL MONITR('SLIANL',SLIANL,SLIANL,SNOANL,LEN)
1777     !       CALL MONITR('PLRANL',PLRANL,SLIANL,SNOANL,LEN)
1778             CALL MONITR('OROG  ',OROG  ,SLIANL,SNOANL,LEN)
1779             CALL MONITR('VEGANL',VEGANL,SLIANL,SNOANL,LEN)
1780             CALL MONITR('VETANL',VETANL,SLIANL,SNOANL,LEN)
1781             CALL MONITR('SOTANL',SOTANL,SLIANL,SNOANL,LEN)
1782     !Cwu [+2L] add sih, sic
1783             CALL MONITR('SIHANL',SIHANL,SLIANL,SNOANL,LEN)
1784             CALL MONITR('SICANL',SICANL,SLIANL,SNOANL,LEN)
1785     !Clu [+4L] add vmn, vmx, slp, abs
1786             CALL MONITR('VMNANL',VMNANL,SLIANL,SNOANL,LEN)
1787             CALL MONITR('VMXANL',VMXANL,SLIANL,SNOANL,LEN)
1788             CALL MONITR('SLPANL',SLPANL,SLIANL,SNOANL,LEN)
1789             CALL MONITR('ABSANL',ABSANL,SLIANL,SNOANL,LEN)
1790            endif
1791     
1792           ENDIF
1793     !
1794     !  Read in forecast fields if needed
1795     !
1796           if (me .eq. 0) then
1797             WRITE(6,*) '=============='
1798             WRITE(6,*) '  FCST GUESS'
1799             WRITE(6,*) '=============='
1800           endif
1801     !
1802             PERCRIT=CRITP2
1803     !
1804           IF(DEADS) THEN
1805     !
1806     !  Fill in guess array with Analysis if dead start.
1807     !
1808             PERCRIT=CRITP3
1809             if (me .eq. 0) WRITE(6,*) 'THIS RUN IS DEAD START RUN'
1810             CALL FILFCS(TSFFCS,WETFCS,SNOFCS,ZORFCS,ALBFCS,
1811          &              TG3FCS,CVFCS ,CVBFCS,CVTFCS,
1812          &              CNPFCS,SMCFCS,STCFCS,SLIFCS,AISFCS,
1813          &              VEGFCS,vetfcs,sotfcs,alffcs,
1814     !Cwu [+1L] add ()fcs for sih, sic
1815          &              SIHFCS,SICFCS,
1816     !Clu [+1L] add ()fcs for vmn, vmx, slp, abs
1817          &              VMNFCS,VMXFCS,SLPFCS,ABSFCS,
1818          &              TSFANL,WETANL,SNOANL,ZORANL,ALBANL,
1819          &              TG3ANL,CVANL ,CVBANL,CVTANL,
1820          &              CNPANL,SMCANL,STCANL,SLIANL,AISANL,
1821          &              VEGANL,vetanl,sotanl,ALFANL,
1822     !Cwu [+1L] add ()anl for sih, sic
1823          &              SIHANL,SICANL,
1824     !Clu [+1L] add ()anl for vmn, vmx, slp, abs
1825          &              VMNANL,VMXANL,SLPANL,ABSANL,     
1826          &              LEN,LSOIL)
1827             IF(SIG1T(1).NE.0.) THEN
1828               CALL USESGT(SIG1T,SLIANL,TG3ANL,LEN,LSOIL,TSFFCS,STCFCS,
1829          &                TSFIMX)
1830              do i=1,len
1831                 icefl2(i) = sicfcs(i) .gt. 0.99999
1832               enddo
1833               KQCM=1
1834               CALL QCMXMN('TSFf    ',TSFFCS,SLIFCS,SNOFCS,icefl2,
1835          &                TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
1836          &                TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
1837          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1838               CALL QCMXMN('STC1f   ',STCFCS(1,1),SLIFCS,SNOFCS,icefl1,
1839          &                STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1840          &                STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1841          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1842               CALL QCMXMN('STC2f   ',STCFCS(1,2),SLIFCS,SNOFCS,icefl1,
1843          &                STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1844          &                STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1845          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1846             ENDIF
1847           ELSE
1848             PERCRIT=CRITP2
1849     !
1850     !  Make reverse angulation correction to TSF
1851     !  Make reverse orography correction to TG3
1852     !
1853     !       ZTSFC=1.
1854     !       CALL TSFCOR(TG3FCS,OROG,SLMASK,ZTSFC,LEN,-RLAPSE)
1855             ZTSFC=0.
1856             CALL TSFCOR(TSFFCS,OROG,SLMASK,ZTSFC,LEN,-RLAPSE)
1857     
1858     !Clu [+12L]  --------------------------------------------------------------
1859     !
1860     !  Compute soil moisture liquid-to-total ratio over land
1861     !
1862             DO J=1, LSOIL
1863             DO I=1, LEN
1864              IF(SMCFCS(I,J) .NE. 0.)  THEN
1865                 SWRATIO(I,J) = SLCFCS(I,J)/SMCFCS(I,J)
1866                ELSE
1867                 SWRATIO(I,J) = -999.
1868              ENDIF
1869             ENDDO
1870             ENDDO
1871     !Clu -----------------------------------------------------------------------
1872     !
1873             IF(LQCBGS .and. irtacn .eq. 0) THEN
1874               CALL QCSLI(SLIANL,SLIFCS,LEN,me)
1875               CALL ALBOCN(ALBFCS,SLMASK,ALBOMX,LEN)
1876              do i=1,len
1877                 icefl2(i) = sicfcs(i) .gt. 0.99999
1878               enddo
1879               KQCM=1
1880               CALL QCMXMN('Snof    ',SNOFCS,SLIFCS,SNOFCS,icefl1,
1881          &                SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
1882          &                SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
1883          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1884               CALL QCMXMN('TSFf    ',TSFFCS,SLIFCS,SNOFCS,icefl2,
1885          &                TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
1886          &                TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
1887          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1888               do kk = 1, 4
1889               CALL QCMXMN('ALBf    ',ALBFCS(1,kk),SLIFCS,SNOFCS,icefl1,
1890          &                ALBLMX,ALBLMN,ALBOMX,ALBOMN,ALBIMX,ALBIMN,
1891          &                ALBJMX,ALBJMN,ALBSMX,ALBSMN,EPSALB,
1892          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1893               enddo
1894             IF(FNWETC(1:8).NE.'        ' .OR. FNWETA(1:8).NE.'        ' )
1895          &                                                          THEN
1896               CALL QCMXMN('WETf    ',WETFCS,SLIFCS,SNOFCS,icefl1,
1897          &                WETLMX,WETLMN,WETOMX,WETOMN,WETIMX,WETIMN,
1898          &                WETJMX,WETJMN,WETSMX,WETSMN,EPSWET,
1899          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1900             ENDIF
1901               CALL QCMXMN('ZORf    ',ZORFCS,SLIFCS,SNOFCS,icefl1,
1902          &                ZORLMX,ZORLMN,ZOROMX,ZOROMN,ZORIMX,ZORIMN,
1903          &                ZORJMX,ZORJMN,ZORSMX,ZORSMN,EPSZOR,
1904          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1905     !       IF(FNPLRC(1:8).NE.'        ' .OR. FNPLRA(1:8).NE.'        ' )
1906     !         CALL QCMXMN('PLNf    ',PLRFCS,SLIFCS,SNOFCS,icefl1,
1907     !    &                PLRLMX,PLRLMN,PLROMX,PLROMN,PLRIMX,PLRIMN,
1908     !    &                PLRJMX,PLRJMN,PLRSMX,PLRSMN,EPSPLR,
1909     !    &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1910     !       ENDIF
1911               CALL QCMXMN('TG3f    ',TG3FCS,SLIFCS,SNOFCS,icefl1,
1912          &                TG3LMX,TG3LMN,TG3OMX,TG3OMN,TG3IMX,TG3IMN,
1913          &                TG3JMX,TG3JMN,TG3SMX,TG3SMN,EPSTG3,
1914          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1915     !Cwu [+8L] ---------------------------------------------------------------
1916               CALL QCMXMN('SIHf    ',SIHFCS,SLIFCS,SNOFCS,icefl1,
1917          &                SIHLMX,SIHLMN,SIHOMX,SIHOMN,SIHIMX,SIHIMN,
1918          &                SIHJMX,SIHJMN,SIHSMX,SIHSMN,EPSSIH,
1919          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1920               CALL QCMXMN('SICf    ',SICFCS,SLIFCS,SNOFCS,icefl1,
1921          &                SICLMX,SICLMN,SICOMX,SICOMN,SICIMX,SICIMN,
1922          &                SICJMX,SICJMN,SICSMX,SICSMN,EPSSIC,
1923          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1924               CALL QCMXMN('SMC1f    ',SMCFCS(1,1),SLIFCS,SNOFCS,icefl1,
1925          &                SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1926          &                SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1927          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1928               CALL QCMXMN('SMC2f   ',SMCFCS(1,2),SLIFCS,SNOFCS,icefl1,
1929          &                SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1930          &                SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1931          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1932     !Clu [+8L] add smcfcs(3:4)
1933               IF(LSOIL.GT.2) THEN
1934               CALL QCMXMN('SMC3f    ',SMCFCS(1,3),SLIFCS,SNOFCS,icefl1,
1935          &                SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1936          &                SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1937          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1938               CALL QCMXMN('SMC4f   ',SMCFCS(1,4),SLIFCS,SNOFCS,icefl1,
1939          &                SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
1940          &                SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
1941          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1942               ENDIF
1943               CALL QCMXMN('STC1f   ',STCFCS(1,1),SLIFCS,SNOFCS,icefl1,
1944          &                STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1945          &                STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1946          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1947               CALL QCMXMN('STC2f   ',STCFCS(1,2),SLIFCS,SNOFCS,icefl1,
1948          &                STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1949          &                STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1950          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1951     !Clu [+8L] add stcfcs(3:4)
1952              IF(LSOIL.GT.2) THEN
1953               CALL QCMXMN('STC3f   ',STCFCS(1,3),SLIFCS,SNOFCS,icefl1,
1954          &                STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1955          &                STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1956          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1957               CALL QCMXMN('STC4f   ',STCFCS(1,4),SLIFCS,SNOFCS,icefl1,
1958          &                STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
1959          &                STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
1960          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1961              ENDIF
1962               CALL QCMXMN('VEGf    ',VEGFCS,SLIFCS,SNOFCS,icefl1,
1963          &                VEGLMX,VEGLMN,VEGOMX,VEGOMN,VEGIMX,VEGIMN,
1964          &                VEGJMX,VEGJMN,VEGSMX,VEGSMN,EPSVEG,
1965          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1966               CALL QCMXMN('VETf    ',VETFCS,SLIFCS,SNOFCS,icefl1,
1967          &                VETLMX,VETLMN,VETOMX,VETOMN,VETIMX,VETIMN,
1968          &                VETJMX,VETJMN,VETSMX,VETSMN,EPSVET,
1969          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1970               CALL QCMXMN('SOTf    ',SOTFCS,SLIFCS,SNOFCS,icefl1,
1971          &                SOTLMX,SOTLMN,SOTOMX,SOTOMN,SOTIMX,SOTIMN,
1972          &                SOTJMX,SOTJMN,SOTSMX,SOTSMN,EPSSOT,
1973          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1974     
1975     !Clu [+16L] ---------------------------------------------------------------
1976               CALL QCMXMN('VMNf    ',VMNFCS,SLIFCS,SNOFCS,icefl1,
1977          &                VMNLMX,VMNLMN,VMNOMX,VMNOMN,VMNIMX,VMNIMN,
1978          &                VMNJMX,VMNJMN,VMNSMX,VMNSMN,EPSVMN,
1979          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1980               CALL QCMXMN('VMXf    ',VMXFCS,SLIFCS,SNOFCS,icefl1,
1981          &                VMXLMX,VMXLMN,VMXOMX,VMXOMN,VMXIMX,VMXIMN,
1982          &                VMXJMX,VMXJMN,VMXSMX,VMXSMN,EPSVMX,
1983          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1984               CALL QCMXMN('SLPf    ',SLPFCS,SLIFCS,SNOFCS,icefl1,
1985          &                SLPLMX,SLPLMN,SLPOMX,SLPOMN,SLPIMX,SLPIMN,
1986          &                SLPJMX,SLPJMN,SLPSMX,SLPSMN,EPSSLP,
1987          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1988               CALL QCMXMN('ABSf    ',ABSFCS,SLIFCS,SNOFCS,icefl1,
1989          &                ABSLMX,ABSLMN,ABSOMX,ABSOMN,ABSIMX,ABSIMN,
1990          &                ABSJMX,ABSJMN,ABSSMX,ABSSMN,EPSABS,
1991          &                RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
1992     !Clu -----------------------------------------------------------------------
1993             ENDIF
1994           ENDIF
1995     !
1996           IF (MONFCS) THEN
1997            if (me .eq. 0) then
1998             PRINT *,' '
1999             PRINT *,'MONITOR OF GUESS'
2000             PRINT *,' '
2001     !       CALL COUNT(SLIFCS,SNOFCS,LEN)
2002             PRINT *,' '
2003             CALL MONITR('TSFFCS',TSFFCS,SLIFCS,SNOFCS,LEN)
2004             CALL MONITR('ALBFCS',ALBFCS,SLIFCS,SNOFCS,LEN)
2005             CALL MONITR('AISFCS',AISFCS,SLIFCS,SNOFCS,LEN)
2006             CALL MONITR('SNOFCS',SNOFCS,SLIFCS,SNOFCS,LEN)
2007             CALL MONITR('SMCFCS1',SMCFCS(1,1),SLIFCS,SNOFCS,LEN)
2008             CALL MONITR('SMCFCS2',SMCFCS(1,2),SLIFCS,SNOFCS,LEN)
2009             CALL MONITR('STCFCS1',STCFCS(1,1),SLIFCS,SNOFCS,LEN)
2010             CALL MONITR('STCFCS2',STCFCS(1,2),SLIFCS,SNOFCS,LEN)
2011     !Clu [+4L] add smcfcs(3:4) and stcfcs(3:4)
2012             IF(LSOIL.GT.2) THEN
2013             CALL MONITR('SMCFCS3',SMCFCS(1,3),SLIFCS,SNOFCS,LEN)
2014             CALL MONITR('SMCFCS4',SMCFCS(1,4),SLIFCS,SNOFCS,LEN)
2015             CALL MONITR('STCFCS3',STCFCS(1,3),SLIFCS,SNOFCS,LEN)
2016             CALL MONITR('STCFCS4',STCFCS(1,4),SLIFCS,SNOFCS,LEN)
2017             ENDIF
2018             CALL MONITR('TG3FCS',TG3FCS,SLIFCS,SNOFCS,LEN)
2019             CALL MONITR('ZORFCS',ZORFCS,SLIFCS,SNOFCS,LEN)
2020     !       IF (GAUS) THEN
2021               CALL MONITR('CVAFCS',CVFCS ,SLIFCS,SNOFCS,LEN)
2022               CALL MONITR('CVBFCS',CVBFCS,SLIFCS,SNOFCS,LEN)
2023               CALL MONITR('CVTFCS',CVTFCS,SLIFCS,SNOFCS,LEN)
2024     !       ENDIF
2025             CALL MONITR('SLIFCS',SLIFCS,SLIFCS,SNOFCS,LEN)
2026     !       CALL MONITR('PLRFCS',PLRFCS,SLIFCS,SNOFCS,LEN)
2027             CALL MONITR('OROG  ',OROG  ,SLIFCS,SNOFCS,LEN)
2028             CALL MONITR('VEGFCS',VEGFCS,SLIFCS,SNOFCS,LEN)
2029             CALL MONITR('VETFCS',VETFCS,SLIFCS,SNOFCS,LEN)
2030             CALL MONITR('SOTFCS',SOTFCS,SLIFCS,SNOFCS,LEN)
2031     !Cwu [+2L] add sih, sic
2032             CALL MONITR('SIHFCS',SIHFCS,SLIFCS,SNOFCS,LEN)
2033             CALL MONITR('SICFCS',SICFCS,SLIFCS,SNOFCS,LEN)
2034     !Clu [+4L] add vmn, vmx, slp, abs
2035             CALL MONITR('VMNFCS',VMNFCS,SLIFCS,SNOFCS,LEN)
2036             CALL MONITR('VMXFCS',VMXFCS,SLIFCS,SNOFCS,LEN)
2037             CALL MONITR('SLPFCS',SLPFCS,SLIFCS,SNOFCS,LEN)
2038             CALL MONITR('ABSFCS',ABSFCS,SLIFCS,SNOFCS,LEN)
2039            endif
2040           ENDIF
2041     !
2042     !...   update annual cycle in the sst guess..
2043     !
2044     !     if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt)
2045     !    *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt)
2046           DO I=1,LEN
2047             IF(SLIANL(I) .EQ. 0.0) THEN
2048               TSFFCS(I)=TSFFCS(I) + (TSFCLM(I) - TSFCL2(I))
2049             ENDIF
2050           ENDDO
2051     !
2052     !  Quality control analysis using forecast guess
2053     !
2054           CALL QCBYFC(TSFFCS,SNOFCS,QCTSFS,QCSNOS,QCTSFI,LEN,LSOIL,
2055          &            SNOANL,AISANL,SLIANL,TSFANL,ALBANL,
2056          &            ZORANL,SMCANL,
2057          &            SMCCLM,TSFSMX,ALBOMX,ZOROMX,me)
2058     !
2059     !  BLEND CLIMATOLOGY AND PREDICTED FIELDS
2060     !
2061           if(me .eq. 0) then
2062             WRITE(6,*) '=============='
2063             WRITE(6,*) '   MERGING'
2064             WRITE(6,*) '=============='
2065           endif
2066     !     if(lprnt) print *,' tsffcs=',tsffcs(iprnt)
2067     !
2068           PERCRIT=CRITP3
2069     !
2070     !  Merge analysis and forecast.  Note TG3, AIS are not merged
2071     !
2072     
2073           CALL MERGE(LEN,LSOIL,IY,IM,ID,IH,FH,
2074     !Cwu [+1L] add ()fcs for sih, sic
2075          &           SIHFCS,SICFCS,
2076     !Clu [+1L] add ()fcs for vmn, vmx, slp, abs
2077          &           VMNFCS,VMXFCS,SLPFCS,ABSFCS, 
2078          &           TSFFCS,WETFCS,SNOFCS,ZORFCS,ALBFCS,AISFCS,
2079          &           CVFCS ,CVBFCS,CVTFCS,
2080          &           CNPFCS,SMCFCS,STCFCS,SLIFCS,VEGFCS,
2081          &           vetfcs,sotfcs,alffcs,
2082     !Cwu [+1L] add ()anl for sih, sic
2083          &           SIHANL,SICANL,                
2084     !Clu [+1L] add ()anl for vmn, vmx, slp, abs
2085          &           VMNANL,VMXANL,SLPANL,ABSANL,       
2086          &           TSFANL,TSFAN2,WETANL,SNOANL,ZORANL,ALBANL,AISANL,
2087          &           CVANL ,CVBANL,CVTANL,
2088          &           CNPANL,SMCANL,STCANL,SLIANL,VEGANL,
2089          &           vetanl,sotanl,ALFANL,
2090          &           CTSFL,CALBL,CAISL,CSNOL,CSMCL,CZORL,CSTCL,CVEGL,
2091          &           CTSFS,CALBS,CAISS,CSNOS,CSMCS,CZORS,CSTCS,CVEGS,
2092          &           CCV,CCVB,CCVT,CCNP,cvetl,cvets,csotl,csots,
2093          &           calfl,calfs,
2094     !Cwu [+1L] add c()l, c()s  for sih, sic
2095          &           CSIHL,CSIHS,CSICL,CSICS,
2096     !Clu [+1L] add c()l, c()s  for vmn, vmx, slp, abs
2097          &           CVMNL,CVMNS,CVMXL,CVMXS,CSLPL,CSLPS,CABSL,CABSS, 
2098          &           IRTTSF,IRTWET,IRTSNO,IRTZOR,IRTALB,IRTAIS,
2099          &           IRTTG3,IRTSCV,IRTACN,IRTSMC,IRTSTC,IRTVEG,
2100     !Clu [+1L] add irt() for vmn, vmx, slp, abs
2101          &           IRTVMN,IRTVMX,IRTSLP,IRTABS,        
2102     !cggg landice start
2103     !cggg     &           irtvet,irtsot,irtalf,me)
2104          &           irtvet,irtsot,irtalf,landice,me)
2105     !cggg landice end
2106           CALL SETZRO(SNOANL,EPSSNO,LEN)
2107     !     if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt)
2108     !     if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt)
2109     
2110     !
2111     !  New ice/Melted ice
2112     !
2113           CALL NEWICE(SLIANL,SLIFCS,TSFANL,TSFFCS,LEN,LSOIL,
2114     !Cwu [+1L] add SIHNEW, AISLIM, SIHANL & SICANL
2115          &            SIHNEW,AISLIM,SIHANL,SICANL,      
2116          &            ALBANL,SNOANL,ZORANL,SMCANL,STCANL,
2117          &            ALBOMX,SNOOMX,ZOROMX,SMCOMX,SMCIMX,
2118     !Cwu [-1L/+1L] change ALBIMX to ALBIMN - NOTE ALBIMX & ALBIMN have been modified
2119     !    &            TSFOMN,TSFIMX,ALBIMX,ZORIMX,TGICE,
2120          &            TSFOMN,TSFIMX,ALBIMN,ZORIMX,TGICE,
2121          &            RLA,RLO,me)
2122     
2123     !     if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt)
2124     !     if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt)
2125     !
2126     !  Set tsfc to TSNOW over snow
2127     !
2128           CALL SNOSFC(SNOANL,TSFANL,TSFSMX,LEN,me)
2129     !
2130           do i=1,len
2131             icefl2(i) = sicanl(i) .gt. 0.99999
2132           enddo
2133           KQCM=0
2134           CALL QCMXMN('SnowM   ',SNOANL,SLIANL,SNOANL,icefl1,
2135          &            SNOLMX,SNOLMN,SNOOMX,SNOOMN,SNOIMX,SNOIMN,
2136          &            SNOJMX,SNOJMN,SNOSMX,SNOSMN,EPSSNO,
2137          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2138           CALL QCMXMN('TsfM    ',TSFANL,SLIANL,SNOANL,icefl2,
2139          &            TSFLMX,TSFLMN,TSFOMX,TSFOMN,TSFIMX,TSFIMN,
2140          &            TSFJMX,TSFJMN,TSFSMX,TSFSMN,EPSTSF,
2141          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2142           do kk = 1, 4
2143           CALL QCMXMN('AlbM    ',ALBANL(1,kk),SLIANL,SNOANL,icefl1,
2144          &            ALBLMX,ALBLMN,ALBOMX,ALBOMN,ALBIMX,ALBIMN,
2145          &            ALBJMX,ALBJMN,ALBSMX,ALBSMN,EPSALB,
2146          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2147           enddo
2148           IF(FNWETC(1:8).NE.'        ' .OR. FNWETA(1:8).NE.'        ' )
2149          &                                                 THEN
2150           CALL QCMXMN('WetM    ',WETANL,SLIANL,SNOANL,icefl1,
2151          &            WETLMX,WETLMN,WETOMX,WETOMN,WETIMX,WETIMN,
2152          &            WETJMX,WETJMN,WETSMX,WETSMN,EPSWET,
2153          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2154           ENDIF
2155           CALL QCMXMN('ZorM    ',ZORANL,SLIANL,SNOANL,icefl1,
2156          &            ZORLMX,ZORLMN,ZOROMX,ZOROMN,ZORIMX,ZORIMN,
2157          &            ZORJMX,ZORJMN,ZORSMX,ZORSMN,EPSZOR,
2158          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2159     !     IF(FNPLRC(1:8).NE.'        ' .OR. FNPLRA(1:8).NE.'        ' )
2160     !    &                                                 THEN
2161     !     CALL QCMXMN('PlntM   ',PLRANL,SLIANL,SNOANL,icefl1,
2162     !    &            PLRLMX,PLRLMN,PLROMX,PLROMN,PLRIMX,PLRIMN,
2163     !    &            PLRJMX,PLRJMN,PLRSMX,PLRSMN,EPSPLR,
2164     !    &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2165     !     ENDIF
2166           CALL QCMXMN('Stc1M   ',STCANL(1,1),SLIANL,SNOANL,icefl1,
2167          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
2168          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
2169          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2170           CALL QCMXMN('Stc2M   ',STCANL(1,2),SLIANL,SNOANL,icefl1,
2171          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
2172          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
2173          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2174     !Clu [+8L] add stcanl(3:4)
2175            IF(LSOIL.GT.2) THEN
2176           CALL QCMXMN('Stc3M   ',STCANL(1,3),SLIANL,SNOANL,icefl1,
2177          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
2178          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
2179          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2180           CALL QCMXMN('Stc4M   ',STCANL(1,4),SLIANL,SNOANL,icefl1,
2181          &            STCLMX,STCLMN,STCOMX,STCOMN,STCIMX,STCIMN,
2182          &            STCJMX,STCJMN,STCSMX,STCSMN,EPTSFC,
2183          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2184            ENDIF
2185           CALL QCMXMN('Smc1M   ',SMCANL(1,1),SLIANL,SNOANL,icefl1,
2186          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
2187          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
2188          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2189           CALL QCMXMN('Smc2M   ',SMCANL(1,2),SLIANL,SNOANL,icefl1,
2190          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
2191          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
2192          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2193     !Clu [+8L] add smcanl(3:4)
2194            IF(LSOIL.GT.2) THEN
2195           CALL QCMXMN('Smc3M   ',SMCANL(1,3),SLIANL,SNOANL,icefl1,
2196          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
2197          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
2198          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2199           CALL QCMXMN('Smc4M   ',SMCANL(1,4),SLIANL,SNOANL,icefl1,
2200          &            SMCLMX,SMCLMN,SMCOMX,SMCOMN,SMCIMX,SMCIMN,
2201          &            SMCJMX,SMCJMN,SMCSMX,SMCSMN,EPSSMC,
2202          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2203           ENDIF
2204           KQCM=1
2205           CALL QCMXMN('VEGm    ',VEGANL,SLIANL,SNOANL,icefl1,
2206          &            VEGLMX,VEGLMN,VEGOMX,VEGOMN,VEGIMX,VEGIMN,
2207          &            VEGJMX,VEGJMN,VEGSMX,VEGSMN,EPSVEG,
2208          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2209           CALL QCMXMN('VETm    ',VETANL,SLIANL,SNOANL,icefl1,
2210          &            VETLMX,VETLMN,VETOMX,VETOMN,VETIMX,VETIMN,
2211          &            VETJMX,VETJMN,VETSMX,VETSMN,EPSVET,
2212          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2213           CALL QCMXMN('SOTm    ',SOTANL,SLIANL,SNOANL,icefl1,
2214          &            SOTLMX,SOTLMN,SOTOMX,SOTOMN,SOTIMX,SOTIMN,
2215          &            SOTJMX,SOTJMN,SOTSMX,SOTSMN,EPSSOT,
2216          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2217     !Cwu [+8L] add sih, sic,
2218           CALL QCMXMN('SIHm    ',SIHANL,SLIANL,SNOANL,icefl1,
2219          &            SIHLMX,SIHLMN,SIHOMX,SIHOMN,SIHIMX,SIHIMN,
2220          &            SIHJMX,SIHJMN,SIHSMX,SIHSMN,EPSSIH,
2221          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2222           CALL QCMXMN('SICm    ',SICANL,SLIANL,SNOANL,icefl1,
2223          &            SICLMX,SICLMN,SICOMX,SICOMN,SICIMX,SICIMN,
2224          &            SICJMX,SICJMN,SICSMX,SICSMN,EPSSIC,
2225          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2226     !Clu [+16L] add vmn, vmx, slp, abs
2227           CALL QCMXMN('VMNm    ',VMNANL,SLIANL,SNOANL,icefl1,
2228          &            VMNLMX,VMNLMN,VMNOMX,VMNOMN,VMNIMX,VMNIMN,
2229          &            VMNJMX,VMNJMN,VMNSMX,VMNSMN,EPSVMN,
2230          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2231           CALL QCMXMN('VMXm    ',VMXANL,SLIANL,SNOANL,icefl1,
2232          &            VMXLMX,VMXLMN,VMXOMX,VMXOMN,VMXIMX,VMXIMN,
2233          &            VMXJMX,VMXJMN,VMXSMX,VMXSMN,EPSVMX,
2234          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2235           CALL QCMXMN('SLPm    ',SLPANL,SLIANL,SNOANL,icefl1,
2236          &            SLPLMX,SLPLMN,SLPOMX,SLPOMN,SLPIMX,SLPIMN,
2237          &            SLPJMX,SLPJMN,SLPSMX,SLPSMN,EPSSLP,
2238          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2239           CALL QCMXMN('ABSm    ',ABSANL,SLIANL,SNOANL,icefl1,
2240          &            ABSLMX,ABSLMN,ABSOMX,ABSOMN,ABSIMX,ABSIMN,
2241          &            ABSJMX,ABSJMN,ABSSMX,ABSSMN,EPSABS,
2242          &            RLA,RLO,LEN,KQCM,PERCRIT,LGCHEK,me)
2243     
2244     !
2245           if(me .eq. 0) then
2246             WRITE(6,*) '=============='
2247             WRITE(6,*) 'FINAL RESULTS'
2248             WRITE(6,*) '=============='
2249           endif
2250     !
2251     !  Foreward correction to TG3 and TSF at the last stage
2252     !
2253     !     if(lprnt) print *,' tsfbc=',tsfanl(iprnt)
2254     !     ZTSFC=1.
2255     !     CALL TSFCOR(TG3ANL,OROG,SLMASK,ZTSFC,LEN,RLAPSE)
2256           ZTSFC=0.
2257           CALL TSFCOR(TSFANL,OROG,SLMASK,ZTSFC,LEN,RLAPSE)
2258     !     if(lprnt) print *,' tsfaf=',tsfanl(iprnt)
2259     !
2260     !  CHECK THE FINAL MERGED PRODUCT
2261     !
2262           IF (MONMER) THEN
2263            if(me .eq. 0) then
2264             PRINT *,' '
2265             PRINT *,'MONITOR OF UPDATED SURFACE FIELDS'
2266             PRINT *,'   (Includes angulation correction)'
2267             PRINT *,' '
2268     !       CALL COUNT(SLIANL,SNOANL,LEN)
2269             PRINT *,' '
2270             CALL MONITR('TSFANL',TSFANL,SLIANL,SNOANL,LEN)
2271             CALL MONITR('ALBANL',ALBANL,SLIANL,SNOANL,LEN)
2272             CALL MONITR('AISANL',AISANL,SLIANL,SNOANL,LEN)
2273             CALL MONITR('SNOANL',SNOANL,SLIANL,SNOANL,LEN)
2274             CALL MONITR('SMCANL1',SMCANL(1,1),SLIANL,SNOANL,LEN)
2275             CALL MONITR('SMCANL2',SMCANL(1,2),SLIANL,SNOANL,LEN)
2276             CALL MONITR('STCANL1',STCANL(1,1),SLIANL,SNOANL,LEN)
2277             CALL MONITR('STCANL2',STCANL(1,2),SLIANL,SNOANL,LEN)
2278     !Clu [+4L] add smcanl(3:4) and stcanl(3:4)
2279             IF(LSOIL.GT.2) THEN
2280             CALL MONITR('SMCANL3',SMCANL(1,3),SLIANL,SNOANL,LEN)
2281             CALL MONITR('SMCANL4',SMCANL(1,4),SLIANL,SNOANL,LEN)
2282             CALL MONITR('STCANL3',STCANL(1,3),SLIANL,SNOANL,LEN)
2283             CALL MONITR('STCANL4',STCANL(1,4),SLIANL,SNOANL,LEN)
2284             CALL MONITR('TG3ANL',TG3ANL,SLIANL,SNOANL,LEN)
2285             CALL MONITR('ZORANL',ZORANL,SLIANL,SNOANL,LEN)
2286             ENDIF
2287     !       IF (GAUS) THEN
2288               CALL MONITR('CVAANL',CVANL ,SLIANL,SNOANL,LEN)
2289               CALL MONITR('CVBANL',CVBANL,SLIANL,SNOANL,LEN)
2290               CALL MONITR('CVTANL',CVTANL,SLIANL,SNOANL,LEN)
2291     !       ENDIF
2292             CALL MONITR('SLIANL',SLIANL,SLIANL,SNOANL,LEN)
2293     !       CALL MONITR('PLRANL',PLRANL,SLIANL,SNOANL,LEN)
2294             CALL MONITR('OROG  ',OROG  ,SLIANL,SNOANL,LEN)
2295             CALL MONITR('CNPANL',CNPANL,SLIANL,SNOANL,LEN)
2296             CALL MONITR('VEGANL',VEGANL,SLIANL,SNOANL,LEN)
2297             CALL MONITR('VETANL',VETANL,SLIANL,SNOANL,LEN)
2298             CALL MONITR('SOTANL',SOTANL,SLIANL,SNOANL,LEN)
2299     !Cwu [+2L] add sih, sic,
2300             CALL MONITR('SIHANL',SIHANL,SLIANL,SNOANL,LEN)
2301             CALL MONITR('SICANL',SICANL,SLIANL,SNOANL,LEN)
2302     !Clu [+4L] add vmn, vmx, slp, abs
2303             CALL MONITR('VMNANL',VMNANL,SLIANL,SNOANL,LEN)
2304             CALL MONITR('VMXANL',VMXANL,SLIANL,SNOANL,LEN)
2305             CALL MONITR('SLPANL',SLPANL,SLIANL,SNOANL,LEN)
2306             CALL MONITR('ABSANL',ABSANL,SLIANL,SNOANL,LEN)
2307            endif
2308           ENDIF
2309     !
2310           IF (MONDIF) THEN
2311             DO I=1,LEN
2312               TSFFCS(I) = TSFANL(I) - TSFFCS(I)
2313               SNOFCS(I) = SNOANL(I) - SNOFCS(I)
2314               TG3FCS(I) = TG3ANL(I) - TG3FCS(I)
2315               ZORFCS(I) = ZORANL(I) - ZORFCS(I)
2316     !         PLRFCS(I) = PLRANL(I) - PLRFCS(I)
2317     !         ALBFCS(I) = ALBANL(I) - ALBFCS(I)
2318               SLIFCS(I) = SLIANL(I) - SLIFCS(I)
2319               AISFCS(I) = AISANL(I) - AISFCS(I)
2320               CNPFCS(I) = CNPANL(I) - CNPFCS(I)
2321               VEGFCS(I) = VEGANL(I) - VEGFCS(I)
2322               VETFCS(I) = VETANL(I) - VETFCS(I)
2323               SOTFCS(I) = SOTANL(I) - SOTFCS(I)
2324     !Clu [+2L] add sih, sic
2325               SIHFCS(I) = SIHANL(I) - SIHFCS(I)
2326               SICFCS(I) = SICANL(I) - SICFCS(I)
2327     !Clu [+4L] add vmn, vmx, slp, abs
2328               VMNFCS(I) = VMNANL(I) - VMNFCS(I)
2329               VMXFCS(I) = VMXANL(I) - VMXFCS(I)
2330               SLPFCS(I) = SLPANL(I) - SLPFCS(I)
2331               ABSFCS(I) = ABSANL(I) - ABSFCS(I)
2332             ENDDO
2333             DO J = 1,LSOIL
2334               DO I = 1,LEN
2335                 SMCFCS(I,J) = SMCANL(I,J) - SMCFCS(I,J)
2336                 STCFCS(I,J) = STCANL(I,J) - STCFCS(I,J)
2337               ENDDO
2338             ENDDO
2339             DO J = 1,4
2340               DO I = 1,LEN
2341                 ALBFCS(I,J) = ALBANL(I,J) - ALBFCS(I,J)
2342               ENDDO
2343             ENDDO
2344     !
2345     !  MONITORING PRINTS
2346     !
2347            if(me .eq. 0) then
2348             PRINT *,' '
2349             PRINT *,'MONITOR OF DIFFERENCE'
2350             PRINT *,'   (Includes angulation correction)'
2351             PRINT *,' '
2352             CALL MONITR('TSFDIF',TSFFCS,SLIANL,SNOANL,LEN)
2353             CALL MONITR('ALBDIF',ALBFCS,SLIANL,SNOANL,LEN)
2354             CALL MONITR('ALBDIF1',ALBFCS,SLIANL,SNOANL,LEN)
2355             CALL MONITR('ALBDIF2',ALBFCS(1,2),SLIANL,SNOANL,LEN)
2356             CALL MONITR('ALBDIF3',ALBFCS(1,3),SLIANL,SNOANL,LEN)
2357             CALL MONITR('ALBDIF4',ALBFCS(1,4),SLIANL,SNOANL,LEN)
2358             CALL MONITR('AISDIF',AISFCS,SLIANL,SNOANL,LEN)
2359             CALL MONITR('SNODIF',SNOFCS,SLIANL,SNOANL,LEN)
2360             CALL MONITR('SMCANL1',SMCFCS(1,1),SLIANL,SNOANL,LEN)
2361             CALL MONITR('SMCANL2',SMCFCS(1,2),SLIANL,SNOANL,LEN)
2362             CALL MONITR('STCANL1',STCFCS(1,1),SLIANL,SNOANL,LEN)
2363             CALL MONITR('STCANL2',STCFCS(1,2),SLIANL,SNOANL,LEN)
2364     !Clu [+4L] add smcfcs(3:4) and stc(3:4)
2365             IF(LSOIL.GT.2) THEN
2366             CALL MONITR('SMCANL3',SMCFCS(1,3),SLIANL,SNOANL,LEN)
2367             CALL MONITR('SMCANL4',SMCFCS(1,4),SLIANL,SNOANL,LEN)
2368             CALL MONITR('STCANL3',STCFCS(1,3),SLIANL,SNOANL,LEN)
2369             CALL MONITR('STCANL4',STCFCS(1,4),SLIANL,SNOANL,LEN)
2370             ENDIF
2371             CALL MONITR('TG3DIF',TG3FCS,SLIANL,SNOANL,LEN)
2372             CALL MONITR('ZORDIF',ZORFCS,SLIANL,SNOANL,LEN)
2373     !       IF (GAUS) THEN
2374               CALL MONITR('CVADIF',CVFCS ,SLIANL,SNOANL,LEN)
2375               CALL MONITR('CVBDIF',CVBFCS,SLIANL,SNOANL,LEN)
2376               CALL MONITR('CVTDIF',CVTFCS,SLIANL,SNOANL,LEN)
2377     !       ENDIF
2378             CALL MONITR('SLIDIF',SLIFCS,SLIANL,SNOANL,LEN)
2379     !       CALL MONITR('PLRDIF',PLRFCS,SLIANL,SNOANL,LEN)
2380             CALL MONITR('CNPDIF',CNPFCS,SLIANL,SNOANL,LEN)
2381             CALL MONITR('VEGDIF',VEGFCS,SLIANL,SNOANL,LEN)
2382             CALL MONITR('VETDIF',VETFCS,SLIANL,SNOANL,LEN)
2383             CALL MONITR('SOTDIF',SOTFCS,SLIANL,SNOANL,LEN)
2384     !Cwu [+2L] add sih, sic
2385             CALL MONITR('SIHDIF',SIHFCS,SLIANL,SNOANL,LEN)
2386             CALL MONITR('SICDIF',SICFCS,SLIANL,SNOANL,LEN)
2387     !Clu [+4L] add vmn, vmx, slp, abs
2388             CALL MONITR('VMNDIF',VMNFCS,SLIANL,SNOANL,LEN)
2389             CALL MONITR('VMXDIF',VMXFCS,SLIANL,SNOANL,LEN)
2390             CALL MONITR('SLPDIF',SLPFCS,SLIANL,SNOANL,LEN)
2391             CALL MONITR('ABSDIF',ABSFCS,SLIANL,SNOANL,LEN)
2392            endif
2393           ENDIF
2394     !
2395     !
2396           DO I=1,LEN
2397             TSFFCS(I) = TSFANL(I)
2398             SNOFCS(I) = SNOANL(I)
2399             TG3FCS(I) = TG3ANL(I)
2400             ZORFCS(I) = ZORANL(I)
2401     !       PLRFCS(I) = PLRANL(I)
2402     !       ALBFCS(I) = ALBANL(I)
2403             SLIFCS(I) = SLIANL(I)
2404             AISFCS(I) = AISANL(I)
2405             CVFCS(I)  = CVANL(I)
2406             CVBFCS(I) = CVBANL(I)
2407             CVTFCS(I) = CVTANL(I)
2408             CNPFCS(I) = CNPANL(I)
2409             vegFCS(I) = vegANL(I)
2410             vetFCS(I) = vetANL(I)
2411             sotFCS(I) = sotANL(I)
2412     !Clu [+4L] add vmn, vmx, slp, abs
2413             VMNFCS(I) = VMNANL(I)
2414             VMXFCS(I) = VMXANL(I)
2415             SLPFCS(I) = SLPANL(I)
2416             ABSFCS(I) = ABSANL(I)
2417           ENDDO
2418           DO J = 1,LSOIL
2419             DO I = 1,LEN
2420               SMCFCS(I,J) = SMCANL(I,J)
2421               IF (SLIFCS(I) .GT. 0.0) THEN
2422                  STCFCS(I,J) = STCANL(I,J)
2423               ELSE
2424                  STCFCS(I,J) = TSFFCS(I)
2425               ENDIF
2426             ENDDO
2427           ENDDO
2428           DO J = 1,4
2429             DO I = 1,LEN
2430               ALBFCS(I,J) = ALBANL(I,J)
2431             ENDDO
2432           ENDDO
2433           DO J = 1,2
2434             DO I = 1,LEN
2435               ALFFCS(I,J) = ALFANL(I,J)
2436             ENDDO
2437           ENDDO
2438     
2439     !Cwu [+20L] update SIHFCS, SICFCS. Remove sea ice over non-ice points
2440           CRIT=AISLIM
2441           DO I=1,LEN
2442             SIHFCS(I) = SIHANL(I)
2443             SITFCS(I) = TSFFCS(I)
2444             IF (SLIFCS(I).GE.2.) THEN
2445               IF (SICFCS(I).GT.CRIT) THEN
2446                 TSFFCS(I) = (SICANL(I)*TSFFCS(I)
2447          &                + (SICFCS(I)-SICANL(I))*TGICE)/SICFCS(I)
2448                 SITFCS(I) = (TSFFCS(I)-TGICE*(1.0-SICFCS(I))) / SICFCS(I)
2449               ELSE
2450                 TSFFCS(I) = Tsfanl(i)
2451     !           TSFFCS(I) = TGICE
2452                 SIHFCS(I) = SIHNEW
2453               ENDIF
2454             ENDIF
2455             SICFCS(I) = SICANL(I)
2456           ENDDO
2457           DO I=1,LEN
2458             IF (SLIFCS(I).LT.1.5) THEN
2459               SIHFCS(I) = 0.
2460               SICFCS(I) = 0.
2461               SITFCS(I) = TSFFCS(I)
2462             ELSE IF ((SLIFCS(I).GE.1.5).AND.(SICFCS(I).LT.CRIT)) THEN
2463               PRINT *,'WARNING: CHECK, SLIFCS and SICFCS',
2464          &            SLIFCS(I),SICFCS(I)
2465             ENDIF
2466           ENDDO
2467     
2468     !Clu [+44L]--------------------------------------------------------------------
2469     !
2470     ! ensure the consistency between slc and smc
2471     !
2472            DO K=1, LSOIL
2473             FIXRATIO(K) = .False.
2474             IF (FSMCL(K).LT.99999.) FIXRATIO(K) = .True.
2475            ENDDO
2476     
2477            if(me .eq. 0) then
2478            print *,'DBGX --fixratio:',(FIXRATIO(K),K=1,LSOIL)
2479            endif
2480     
2481            DO K=1, LSOIL
2482             IF(FIXRATIO(K)) THEN
2483              DO I = 1, LEN
2484                IF(SWRATIO(I,K) .EQ. -999.) THEN
2485                 SLCFCS(I,K) = SMCFCS(I,K)
2486                ELSE
2487                 SLCFCS(I,K) = SWRATIO(I,K) * SMCFCS(I,K)
2488                ENDIF
2489     !cggg
2490                if (slifcs(i) .ne. 1.0) slcfcs(i,k) = 1.0  ! flag value for non-land points.
2491              ENDDO
2492             ENDIF
2493            ENDDO
2494     !cggg landice start
2495     !cggg set liquid soil moisture to a flag value of 1.0
2496            IF (LANDICE) THEN
2497              DO I = 1, LEN
2498                IF (SLIFCS(I) .EQ. 1.0 .AND. VETFCS(I) == 13.0) THEN
2499                  DO K=1, LSOIL
2500                    SLCFCS(I,K) = 1.0
2501                  ENDDO
2502                ENDIF
2503              ENDDO
2504            END IF
2505     !cggg landice end
2506     !
2507     ! ensure the consistency between snwdph and sheleg
2508     !
2509           IF(FSNOL .LT. 99999.) THEN  
2510            if(me .eq. 0) then
2511            print *,'DBGX -- scale snwdph from sheleg'
2512            endif
2513            DO I = 1, LEN
2514             IF(SLIFCS(I).EQ.1.) SWDFCS(I) = 10.* SNOFCS(I)
2515            ENDDO
2516           ENDIF
2517     
2518     ! sea ice model only uses the liquid equivalent depth.
2519     ! so update the physical depth only for display purposes.
2520     ! use the same 3:1 ratio used by ice model.
2521     
2522           do i = 1, len
2523             if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i)
2524           enddo
2525     
2526           DO I = 1, LEN
2527             IF(SLIFCS(I).EQ.1.) THEN
2528             IF(SNOFCS(I).NE.0. .AND. SWDFCS(I).EQ.0.) THEN
2529               print *,'DBGX --scale snwdph from sheleg',
2530          +        I, SWDFCS(I), SNOFCS(I)
2531               SWDFCS(I) = 10.* SNOFCS(I)
2532             ENDIF
2533             ENDIF
2534           ENDDO
2535     !cggg landice mods start  - impose same minimum snow depth at
2536     !cggg                       landice as noah lsm.  also ensure
2537     !cggg                       lower thermal boundary condition
2538     !cggg                       and skin t is no warmer than freezing
2539     !cggg                       after adjustment to terrain.
2540            IF (LANDICE) THEN
2541              DO I = 1, LEN
2542                IF (SLIFCS(I) .EQ. 1.0 .AND. VETFCS(I) == 13.0) THEN
2543                  SNOFCS(I) = MAX(SNOFCS(I),100.0)  ! IN MM
2544                  SWDFCS(I) = MAX(SWDFCS(I),1000.0) ! IN MM
2545                  TG3FCS(I) = MIN(TG3FCS(I),273.15)
2546                  TSFFCS(I) = MIN(TSFFCS(I),273.15)
2547                ENDIF
2548              ENDDO
2549            END IF
2550     !cggg landice mods end
2551     !Clu---------------------------------------------------------------------------
2552     !
2553     !     if(lprnt) print *,' tsffcsF=',tsffcs(iprnt)
2554           RETURN
2555           END SUBROUTINE SFCCYCLE 
2556           SUBROUTINE COUNT(SLIMSK,SNO,IJMAX)
2557           USE MACHINE , ONLY : kind_io8,kind_io4
2558           implicit none
2559           real (kind=kind_io8) rl3,rl1,rl0,rl2,rl6,rl7,rl4,rl5
2560           integer l8,l7,l1,l2,ijmax,l0,l3,l5,l6,l4,ij
2561     !
2562           REAL (KIND=KIND_IO8) SLIMSK(1),SNO(1)
2563     !
2564     !  COUNT NUMBER OF POINTS FOR THE FOUR SURFACE CONDITIONS
2565     !
2566           L0 = 0
2567           L1 = 0
2568           L2 = 0
2569           L3 = 0
2570           L4 = 0
2571           DO IJ=1,IJMAX
2572             IF(SLIMSK(IJ).EQ.0.) L1 = L1 + 1
2573             IF(SLIMSK(IJ).EQ.1. .AND. SNO(IJ).LE.0.) L0 = L0 + 1
2574             IF(SLIMSK(IJ).EQ.2. .AND. SNO(IJ).LE.0.) L2 = L2 + 1
2575             IF(SLIMSK(IJ).EQ.1. .AND. SNO(IJ).GT.0.) L3 = L3 + 1
2576             IF(SLIMSK(IJ).EQ.2. .AND. SNO(IJ).GT.0.) L4 = L4 + 1
2577           ENDDO
2578           L5  = L0 + L3
2579           L6  = L2 + L4
2580           L7  = L1 + L6
2581           L8  = L1 + L5 + L6
2582           RL0 = FLOAT(L0) / FLOAT(L8)*100.
2583           RL3 = FLOAT(L3) / FLOAT(L8)*100.
2584           RL1 = FLOAT(L1) / FLOAT(L8)*100.
2585           RL2 = FLOAT(L2) / FLOAT(L8)*100.
2586           RL4 = FLOAT(L4) / FLOAT(L8)*100.
2587           RL5 = FLOAT(L5) / FLOAT(L8)*100.
2588           RL6 = FLOAT(L6) / FLOAT(L8)*100.
2589           RL7 = FLOAT(L7) / FLOAT(L8)*100.
2590           PRINT *,'1) NO. OF NOT SNOW-COVERED LAND POINTS   ',L0,' ',RL0,' '
2591           PRINT *,'2) NO. OF SNOW COVERED LAND POINTS       ',L3,' ',RL3,' '
2592           PRINT *,'3) NO. OF OPEN SEA POINTS                ',L1,' ',RL1,' '
2593           PRINT *,'4) NO. OF NOT SNOW-COVERED SEAICE POINTS ',L2,' ',RL2,' '
2594           PRINT *,'5) NO. OF SNOW COVERED SEA ICE POINTS    ',L4,' ',RL4,' '
2595           PRINT *,' '
2596           PRINT *,'6) NO. OF LAND POINTS                    ',L5,' ',RL5,' '
2597           PRINT *,'7) NO. SEA POINTS (INCLUDING SEA ICE)    ',L7,' ',RL7,' '
2598           PRINT *,'   (NO. OF SEA ICE POINTS)          (',L6,')',' ',RL6,' '
2599           PRINT *,' '
2600           PRINT *,'9) NO. OF TOTAL GRID POINTS               ',L8
2601     !     PRINT *,' '
2602     !     PRINT *,' '
2603     
2604     !
2605     !     if(lprnt) print *,' tsffcsF=',tsffcs(iprnt)
2606           RETURN
2607           END
2608           SUBROUTINE MONITR(LFLD,FLD,SLIMSK,SNO,IJMAX)
2609           USE MACHINE , ONLY : kind_io8,kind_io4
2610           implicit none
2611           integer ij,n,ijmax
2612     !
2613           REAL (KIND=KIND_IO8) FLD(IJMAX), SLIMSK(IJMAX),SNO(IJMAX)
2614     !
2615           REAL (KIND=KIND_IO8) RMAX(5),RMIN(5)
2616           CHARACTER*8 LFLD
2617     !
2618     !  FIND MAX/MIN
2619     !
2620           DO N=1,5
2621             RMAX(N) = -9.E20
2622             RMIN(N) =  9.E20
2623           ENDDO
2624     !
2625           DO IJ=1,IJMAX
2626              IF(SLIMSK(IJ).EQ.0.) THEN
2627                 RMAX(1) = MAX(RMAX(1), FLD(IJ))
2628                 RMIN(1) = MIN(RMIN(1), FLD(IJ))
2629              ELSEIF(SLIMSK(IJ).EQ.1.) THEN
2630                 IF(SNO(IJ).LE.0.) THEN
2631                    RMAX(2) = MAX(RMAX(2), FLD(IJ))
2632                    RMIN(2) = MIN(RMIN(2), FLD(IJ))
2633                 ELSE
2634                    RMAX(4) = MAX(RMAX(4), FLD(IJ))
2635                    RMIN(4) = MIN(RMIN(4), FLD(IJ))
2636                 ENDIF
2637              ELSE
2638                 IF(SNO(IJ).LE.0.) THEN
2639                    RMAX(3) = MAX(RMAX(3), FLD(IJ))
2640                    RMIN(3) = MIN(RMIN(3), FLD(IJ))
2641                 ELSE
2642                    RMAX(5) = MAX(RMAX(5), FLD(IJ))
2643                    RMIN(5) = MIN(RMIN(5), FLD(IJ))
2644                 ENDIF
2645              ENDIF
2646           ENDDO
2647     !
2648           PRINT 100,LFLD
2649           PRINT 101,RMAX(1),RMIN(1)
2650           PRINT 102,RMAX(2),RMIN(2), RMAX(4), RMIN(4)
2651           PRINT 103,RMAX(3),RMIN(3), RMAX(5), RMIN(5)
2652     !
2653     !     PRINT 102,RMAX(2),RMIN(2)
2654     !     PRINT 103,RMAX(3),RMIN(3)
2655     !     PRINT 104,RMAX(4),RMIN(4)
2656     !     PRINT 105,RMAX(5),RMIN(5)
2657       100 FORMAT('0  *** ',A8,' ***')
2658       101 FORMAT(' OPEN SEA  ......... MAX=',E12.4,' MIN=',E12.4)
2659       102 FORMAT(' LAND NOSNOW/SNOW .. MAX=',E12.4,' MIN=',E12.4
2660          &,                          ' MAX=',E12.4,' MIN=',E12.4)
2661       103 FORMAT(' SEAICE NOSNOW/SNOW  MAX=',E12.4,' MIN=',E12.4
2662          &,                          ' MAX=',E12.4,' MIN=',E12.4)
2663     !
2664     ! 100 FORMAT('0',2X,'*** ',A8,' ***')
2665     ! 102 FORMAT(2X,' LAND WITHOUT SNOW ..... MAX=',E12.4,' MIN=',E12.4)
2666     ! 103 FORMAT(2X,' SEAICE WITHOUT SNOW ... MAX=',E12.4,' MIN=',E12.4)
2667     ! 104 FORMAT(2X,' LAND WITH SNOW ........ MAX=',E12.4,' MIN=',E12.4)
2668     ! 105 FORMAT(2X,' SEA ICE WITH SNOW ..... MAX=',E12.4,' MIN=',E12.4)
2669     !
2670           RETURN
2671           END
2672           SUBROUTINE DAYOYR(IYR,IMO,IDY,LDY)
2673           implicit none
2674           integer ldy,i,idy,iyr,imo
2675     !
2676     !  THIS ROUTINE FIGURES OUT THE DAY OF THE YEAR GIVEN IMO AND IDY
2677     !
2678           INTEGER MONTH(13)
2679           DATA MONTH/0,31,28,31,30,31,30,31,31,30,31,30,31/
2680           IF(MOD(IYR,4).EQ.0) MONTH(3) = 29
2681           LDY = IDY
2682           DO I = 1, IMO
2683             LDY = LDY + MONTH(I)
2684           ENDDO
2685           RETURN
2686           END
2687           SUBROUTINE HMSKRD(LUGB,IMSK,JMSK,FNMSKH,
2688          &                  KPDS5,SLMSKH,GAUSM,BLNMSK,BLTMSK,me)
2689           USE MACHINE , ONLY : kind_io8,kind_io4
2690           implicit none
2691           integer kpds5,me,i,imsk,jmsk,lugb,mdata
2692     !
2693           CHARACTER*500 FNMSKH
2694     !Clu [-1L/+1L] increase the dimension size
2695     !Clu  PARAMETER(MDATA=2048*1024)
2696           PARAMETER(MDATA=2500*1250)
2697     !     PARAMETER(MDATA=5800*2900)        !hmhj
2698     !
2699           REAL (KIND=KIND_IO8) SLMSKH(MDATA)
2700           LOGICAL GAUSM
2701           REAL (KIND=KIND_IO8) BLNMSK,BLTMSK
2702     !
2703     
2704     !Clu [-2L/+2L] increase the dimension size
2705     !Clu  IMSK = 2048
2706     !Clu  JMSK = 1024
2707           IMSK = 2500
2708           JMSK = 1250
2709     !     IMSK = 5800       !hmhj
2710     !     JMSK = 2900       !hmhj
2711           CALL FIXRDG(LUGB,IMSK,JMSK,FNMSKH,
2712          &            KPDS5,SLMSKH,GAUSM,BLNMSK,BLTMSK,me)
2713           DO I=1,IMSK*JMSK
2714              SLMSKH(I) = NINT(SLMSKH(I))
2715           ENDDO
2716     !
2717           RETURN
2718           END
2719           SUBROUTINE FIXRDG(LUGB,IDIM,JDIM,FNGRIB,
2720          &                  KPDS5,GDATA,GAUS,BLNO,BLTO,me)
2721           USE MACHINE , ONLY : kind_io8,kind_io4
2722           implicit none
2723           integer lgrib,n,lskip,jret,j,ndata,lugi,jdim,idim,lugb,
2724          &        iret, me,kpds5,mdata,kdata,i
2725     !
2726           CHARACTER*500 FNGRIB
2727     !Clu [-1L/+1L] increase the dimension size
2728     !Clu  PARAMETER(MDATA=2048*1024)
2729           PARAMETER(MDATA=2500*1250)
2730     !     PARAMETER(MDATA=5800*2900)        !hmhj
2731     !
2732           REAL (KIND=KIND_IO8) GDATA(IDIM*JDIM)
2733           LOGICAL GAUS
2734           REAL (KIND=KIND_IO8) BLNO,BLTO
2735           real(kind=kind_io8) data4(idim*jdim)
2736     !
2737           LOGICAL*1 LBMS(MDATA)
2738     !
2739           INTEGER KPDS(200),KGDS(200)
2740           INTEGER JPDS(200),JGDS(200), KPDS0(200)
2741     !
2742     !     if(me .eq. 0) then
2743     !     WRITE(6,*) ' '
2744     !     WRITE(6,*) '************************************************'
2745     !     endif
2746     !
2747           CLOSE(LUGB)
2748           call baopenr(lugb,fngrib,iret)
2749           IF (IRET .NE. 0) THEN
2750             WRITE(6,*) ' ERROR IN OPENING FILE ',trim(FNGRIB)
2751             PRINT *,'ERROR IN OPENING FILE ',trim(FNGRIB)
2752             CALL ABORT
2753           ENDIF
2754           if (me .eq. 0) WRITE(6,*) ' FILE ',trim(FNGRIB),
2755          &              ' opened. Unit=',LUGB
2756           lugi    = 0
2757           lskip   = -1
2758           N       = 0
2759           JPDS    = -1
2760           JGDS    = -1
2761           JPDS(5) = KPDS5
2762           KPDS    = JPDS
2763     !
2764           call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata,
2765          &            lskip,kpds,kgds,iret)
2766     !
2767           if(me .eq. 0) then
2768             WRITE(6,*) ' First grib record.'
2769             WRITE(6,*) ' KPDS( 1-10)=',(KPDS(J),J= 1,10)
2770             WRITE(6,*) ' KPDS(11-20)=',(KPDS(J),J=11,20)
2771             WRITE(6,*) ' KPDS(21-  )=',(KPDS(J),J=21,22)
2772           endif
2773     !
2774           KPDS0=JPDS
2775           KPDS0(4)=-1
2776           KPDS0(18)=-1
2777           IF(IRET.NE.0) THEN
2778             WRITE(6,*) ' Error in GETGBH. IRET: ', iret
2779             IF (IRET == 99) WRITE(6,*) ' Field not found.'
2780             CALL ABORT
2781           ENDIF
2782     !
2783           jpds = kpds0
2784           lskip = -1
2785           kdata=idim*jdim
2786           call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip,
2787          &                kpds,kgds,lbms,data4,jret)
2788     !
2789           if(jret.eq.0) then
2790             IF(NDATA.EQ.0) THEN
2791               WRITE(6,*) ' Error in getgb'
2792               WRITE(6,*) ' KPDS=',KPDS
2793               WRITE(6,*) ' KGDS=',KGDS
2794               CALL ABORT
2795             ENDIF
2796             IDIM=KGDS(2)
2797             JDIM=KGDS(3)
2798             gaus=kgds(1).eq.4
2799             blno=kgds(5)*1.d-3
2800             blto=kgds(4)*1.d-3
2801             gdata(1:idim*jdim)=data4(1:idim*jdim)
2802             if (me .eq. 0) WRITE(6,*) 'IDIM,JDIM=',IDIM,JDIM
2803          &,                ' gaus=',gaus,' blno=',blno,' blto=',blto
2804           ELSE
2805             WRITE(6,*) ' Error in GETGB : JRET=',JRET
2806             WRITE(6,*) ' KPDS(13)=',KPDS(13),' KPDS(15)=',KPDS(15)
2807             CALL ABORT
2808           ENDIF
2809     !
2810           RETURN
2811           END
2812           SUBROUTINE GETAREA(KGDS,DLAT,DLON,RSLAT,RNLAT,WLON,ELON,IJORDR
2813          &,                  me)
2814           USE MACHINE , ONLY : kind_io8,kind_io4
2815           implicit none
2816           integer j,me,kgds11
2817           real (kind=kind_io8) f0lon,f0lat,elon,dlon,dlat,rslat,wlon,rnlat
2818     !
2819     !  Get area of the grib record
2820     !
2821           Integer KGDS(22)
2822           LOGICAL IJORDR
2823     !
2824           if (me .eq. 0) then
2825            WRITE(6,*) ' KGDS( 1-12)=',(KGDS(J),J= 1,12)
2826            WRITE(6,*) ' KGDS(13-22)=',(KGDS(J),J=13,22)
2827           endif
2828     !
2829           IF(KGDS(1).EQ.0) THEN                      !  Lat/Lon grid
2830     !
2831             if (me .eq. 0) WRITE(6,*) 'LAT/LON GRID'
2832             DLAT   = FLOAT(KGDS(10)) * 0.001
2833             DLON   = FLOAT(KGDS( 9)) * 0.001
2834             F0LON  = FLOAT(KGDS(5))  * 0.001
2835             F0LAT  = FLOAT(KGDS(4))  * 0.001
2836             KGDS11 = KGDS(11)
2837             IF(KGDS11.GE.128) THEN
2838               WLON = F0LON - DLON*(KGDS(2)-1)
2839               ELON = F0LON
2840               IF(DLON*KGDS(2).GT.359.99) THEN
2841                 WLON =F0LON - DLON*KGDS(2)
2842               ENDIF
2843               DLON   = -DLON
2844               KGDS11 = KGDS11 - 128
2845             ELSE
2846               WLON = F0LON
2847               ELON = F0LON + DLON*(KGDS(2)-1)
2848               IF(DLON*KGDS(2).GT.359.99) THEN
2849                 ELON = F0LON + DLON*KGDS(2)
2850               ENDIF
2851             ENDIF
2852             IF(KGDS11.GE.64) THEN
2853               RNLAT  = F0LAT + DLAT*(KGDS(3)-1)
2854               RSLAT  = F0LAT
2855               KGDS11 = KGDS11 - 64
2856             ELSE
2857               RNLAT = F0LAT
2858               RSLAT = F0LAT - DLAT*(KGDS(3)-1)
2859               DLAT  = -DLAT
2860             ENDIF
2861             IF(KGDS11.GE.32) THEN
2862               IJORDR = .FALSE.
2863             ELSE
2864               IJORDR = .TRUE.
2865             ENDIF
2866     
2867             IF(WLON.GT.180.) WLON = WLON - 360.
2868             IF(ELON.GT.180.) ELON = ELON - 360.
2869             WLON  = NINT(WLON*1000.)  * 0.001
2870             ELON  = NINT(ELON*1000.)  * 0.001
2871             RSLAT = NINT(RSLAT*1000.) * 0.001
2872             RNLAT = NINT(RNLAT*1000.) * 0.001
2873             RETURN
2874     !
2875           ELSEIF(KGDS(1).EQ.1) THEN                  !  Mercator projection
2876             WRITE(6,*) 'Mercator GRID'
2877             WRITE(6,*) 'Cannot process'
2878             CALL ABORT
2879     !
2880           ELSEIF(KGDS(1).EQ.2) THEN                  !  Gnomonic projection
2881             WRITE(6,*) 'Gnomonic GRID'
2882             WRITE(6,*) 'ERROR!! Gnomonic projection not coded'
2883             CALL ABORT
2884     !
2885           ELSEIF(KGDS(1).EQ.3) THEN                  !  Lambert conformal
2886             WRITE(6,*) 'Lambert conformal'
2887             WRITE(6,*) 'Cannot process'
2888             CALL ABORT
2889           ELSEIF(KGDS(1).EQ.4) THEN                  !  Gaussian grid
2890     !
2891             if (me .eq. 0) WRITE(6,*) 'Gaussian GRID'
2892             DLAT   = 99.
2893             DLON   = FLOAT(KGDS( 9)) / 1000.0
2894             F0LON  = FLOAT(KGDS(5))  / 1000.0
2895             F0LAT  = 99.
2896             KGDS11 = KGDS(11)
2897             IF(KGDS11.GE.128) THEN
2898               WLON = F0LON
2899               ELON = F0LON
2900               IF(DLON*KGDS(2).GT.359.99) THEN
2901                 WLON = F0LON - DLON*KGDS(2)
2902               ENDIF
2903               DLON   = -DLON
2904               KGDS11 = KGDS11-128
2905             ELSE
2906               WLON = F0LON
2907               ELON = F0LON + DLON*(KGDS(2)-1)
2908               IF(DLON*KGDS(2).GT.359.99) THEN
2909                 ELON = F0LON + DLON*KGDS(2)
2910               ENDIF
2911             ENDIF
2912             IF(KGDS11.GE.64) THEN
2913               RNLAT  = 99.
2914               RSLAT  = 99.
2915               KGDS11 = KGDS11 - 64
2916             ELSE
2917               RNLAT = 99.
2918               RSLAT = 99.
2919               DLAT  = -99.
2920             ENDIF
2921             IF(KGDS11.GE.32) THEN
2922               IJORDR = .FALSE.
2923             ELSE
2924               IJORDR = .TRUE.
2925             ENDIF
2926             RETURN
2927     !
2928           ELSEIF(KGDS(1).EQ.5) THEN                  !  Polar Strereographic
2929             WRITE(6,*) 'Polar Stereographic GRID'
2930             WRITE(6,*) 'Cannot process'
2931             CALL ABORT
2932             RETURN
2933     !
2934           ELSEIF(KGDS(1).EQ.13) THEN                 !  Oblique Lambert conformal
2935             WRITE(6,*) 'Oblique Lambert conformal GRID'
2936             WRITE(6,*) 'Cannot process'
2937             CALL ABORT
2938     !
2939           ELSEIF(KGDS(1).EQ.50) THEN                 !  Spherical Coefficient
2940             WRITE(6,*) 'Spherical Coefficient'
2941             WRITE(6,*) 'Cannot process'
2942             CALL ABORT
2943             RETURN
2944     !
2945           ELSEIF(KGDS(1).EQ.90) THEN                 !  Space view perspective
2946     !                                                  (orthographic grid)
2947             WRITE(6,*) 'Space view perspective GRID'
2948             WRITE(6,*) 'Cannot process'
2949             CALL ABORT
2950             RETURN
2951     !
2952           ELSE                                       !  Unknown projection.  Abort.
2953             WRITE(6,*) 'ERROR!! Unknown map projection'
2954             WRITE(6,*) 'KGDS(1)=',KGDS(1)
2955             PRINT *,'ERROR!! Unknown map projection'
2956             PRINT *,'KGDS(1)=',KGDS(1)
2957             CALL ABORT
2958           ENDIF
2959     !
2960           RETURN
2961           END
2962           SUBROUTINE SUBST(DATA,IMAX,JMAX,IJMAX,DLON,DLAT,IJORDR,WORK)
2963           USE MACHINE , ONLY : kind_io8,kind_io4
2964           implicit none
2965           integer j,ij,i,ijo,ji,jmax,imax,ijmax
2966           REAL (KIND=KIND_IO8) dlat,dlon
2967     !
2968           LOGICAL IJORDR
2969     !
2970           REAL (KIND=KIND_IO8) DATA(IJMAX), WORK(IJMAX)
2971     !
2972           IF(.NOT.IJORDR.OR.
2973          &  (IJORDR.AND.(DLAT.GT.0..OR.DLON.LT.0.))) THEN
2974             IF(.NOT.IJORDR) THEN
2975               IJ=0
2976               DO J=1,JMAX
2977                 DO I=1,IMAX
2978                   IJ       = (J-1)*IMAX+I
2979                   JI       = (I-1)*JMAX+J
2980                   WORK(IJ) = DATA(JI)
2981                 ENDDO
2982               ENDDO
2983             ELSE
2984               DO J=1,JMAX
2985                 DO I=1,IMAX
2986                   IJ       = (J-1)*IMAX+I
2987                   WORK(IJ) = DATA(IJ)
2988                 ENDDO
2989               ENDDO
2990             ENDIF
2991             DO J=1,JMAX
2992               DO I=1,IMAX
2993                 IF(DLAT.GT.0..AND.DLON.GT.0.) THEN
2994                   IJ = IMAX*JMAX - IMAX*J + I
2995                 ELSEIF(DLAT.GT.0..AND.DLON.LT.0.) THEN
2996                   IJ = IMAX*JMAX - (J-1)*IMAX - IMAX + I - 1
2997                 ELSEIF(DLAT.LT.0..AND.DLON.LT.0.) THEN
2998                   IJ = IMAX*(J-1) + IMAX - I + 1
2999                 ENDIF
3000                 IJO      = (J-1)*IMAX + I
3001                 DATA(IJ) = WORK(IJO)
3002               ENDDO
3003             ENDDO
3004           ENDIF
3005           RETURN
3006           END
3007           SUBROUTINE LA2GA(REGIN,IMXIN,JMXIN,RINLON,RINLAT,RLON,RLAT,INTTYP,
3008          &                 GAUOUT,LEN,LMASK,RSLMSK,SLMASK
3009          &,                OUTLAT, OUTLON,me)
3010           USE MACHINE , ONLY : kind_io8,kind_io4
3011           implicit none
3012           REAL (KIND=KIND_IO8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4,
3013          &                     wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1,
3014          &                     wi1j2,wi2j1,rlat,rlon,aphi,
3015          &                     rnume,alamd,denom
3016           integer jy,ifill,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2,
3017          &        ii,i1,i2,KMAMI,it
3018           integer nx,kxs,kxt,imxnx
3019     !
3020     !  INTERPOLATION FROM LAT/LON OR GAUSSIAN GRID TO OTHER LAT/LON GRID
3021     !
3022           REAL (KIND=KIND_IO8) OUTLON(LEN),OUTLAT(LEN),GAUOUT(LEN),
3023          &                     SLMASK(LEN)
3024           REAL (KIND=KIND_IO8) REGIN (IMXIN,JMXIN),RSLMSK(IMXIN,JMXIN)
3025     !
3026           REAL (KIND=KIND_IO8)    RINLAT(JMXIN),  RINLON(IMXIN)
3027           INTEGER IINDX1(LEN),    IINDX2(LEN)
3028           INTEGER JINDX1(LEN),    JINDX2(LEN)
3029           REAL (KIND=KIND_IO8)    DDX(LEN),       DDY(LEN),   WRK(LEN)
3030     !
3031           LOGICAL LMASK
3032     !
3033           logical first
3034           integer   NUM_THREADS
3035           data first /.true./
3036           save NUM_THREADS, first
3037     !
3038           integer LEN_THREAD_M, LEN_THREAD, I1_T, I2_T
3039           integer NUM_PARTHDS
3040     !
3041           if (first) then
3042              NUM_THREADS    = NUM_PARTHDS()
3043              first = .false.
3044           endif
3045     !
3046     !
3047     !     if(me .eq. 0) then
3048     !     PRINT *,'RLON=',RLON,' me=',me
3049     !     PRINT *,'RLAT=',RLAT,' me=',me,' imxin=',imxin,' jmxin=',jmxin
3050     !     endif
3051     !
3052     !     DO J=1,JMXIN
3053     !       IF(RLAT.GT.0.) THEN
3054     !         RINLAT(J) = RLAT - FLOAT(J-1)*DLAIN
3055     !       ELSE
3056     !         RINLAT(J) = RLAT + FLOAT(J-1)*DLAIN
3057     !       ENDIF
3058     !     ENDDO
3059     !
3060     !     if (me .eq. 0) then
3061     !       PRINT *,'RINLAT='
3062     !       PRINT *,(RINLAT(J),J=1,JMXIN)
3063     !       PRINT *,'RINLON='
3064     !       PRINT *,(RINLON(I),I=1,IMXIN)
3065     !
3066     !       PRINT *,'OUTLAT='
3067     !       PRINT *,(OUTLAT(J),J=1,LEN)
3068     !       PRINT *,(OUTLON(J),J=1,LEN)
3069     !     endif
3070     !
3071     !     DO I=1,IMXIN
3072     !       RINLON(I) = RLON + FLOAT(I-1)*DLOIN
3073     !     ENDDO
3074     !
3075     !     PRINT *,'RINLON='
3076     !     PRINT *,(RINLON(I),I=1,IMXIN)
3077     !
3078           LEN_THREAD_M  = (LEN+NUM_THREADS-1) / NUM_THREADS
3079     !
3080     !$OMP PARALLEL DO PRIVATE(I1_T,I2_T,LEN_THREAD,IT,I,II,I1,I2)
3081     !$OMP+PRIVATE(J,J1,J2,JQ,IX,JY,NX,KXS,KXT,IMXNX,KMAMI)
3082     !$OMP+PRIVATE(ALAMD,DENOM,RNUME,APHI,X,Y,WSUM,WSUMIV,SUM1,SUM2)
3083     !$OMP+PRIVATE(SUM3,SUM4,WI1J1,WI2J1,WI1J2,WI2J2,WEI1,WEI2,WEI3,WEI4)
3084     !$OMP+PRIVATE(SUMN,SUMS)
3085     !$OMP+SHARED(IMXIN,JMXIN,IFILL)
3086     !$OMP+SHARED(OUTLON,OUTLAT,WRK,IINDX1,RINLON,JINDX1,RINLAT,DDX,DDY)
3087     !$OMP+SHARED(RLON,RLAT,REGIN,GAUOUT)
3088     !
3089           DO IT=1,NUM_THREADS   ! START OF THREADED LOOP ...................
3090             I1_T       = (IT-1)*LEN_THREAD_M+1
3091             I2_T       = MIN(I1_T+LEN_THREAD_M-1,LEN)
3092             LEN_THREAD = I2_T-I1_T+1
3093     !
3094     !       FIND I-INDEX FOR INTERPOLATION
3095     !
3096             DO I=I1_T, I2_T
3097               ALAMD = OUTLON(I)
3098               IF (ALAMD .LT. RLON)   ALAMD = ALAMD + 360.0
3099               IF (ALAMD .GT. 360.0+RLON) ALAMD = ALAMD - 360.0
3100               WRK(I)    = ALAMD
3101               IINDX1(I) = IMXIN
3102             ENDDO
3103             DO I=I1_T,I2_T
3104               DO II=1,IMXIN
3105                 IF(WRK(I) .GE. RINLON(II)) IINDX1(I) = II
3106               ENDDO
3107             ENDDO
3108             DO I=I1_T,I2_T
3109               I1 = IINDX1(I)
3110               IF (I1 .LT. 1) I1 = IMXIN
3111               I2 = I1 + 1
3112               IF (I2 .GT. IMXIN) I2 = 1
3113               IINDX1(I) = I1
3114               IINDX2(I) = I2
3115               DENOM     = RINLON(I2) - RINLON(I1)
3116               IF(DENOM.LT.0.) DENOM = DENOM + 360.
3117               RNUME = WRK(I) - RINLON(I1)
3118               IF(RNUME.LT.0.) RNUME = RNUME + 360.
3119               DDX(I) = RNUME / DENOM
3120             ENDDO
3121     !
3122     !  FIND J-INDEX FOR INTERPLATION
3123     !
3124             IF(RLAT.GT.0.) THEN
3125               DO J=I1_T,I2_T
3126                 JINDX1(J)=0
3127               ENDDO
3128               DO JX=1,JMXIN
3129                 DO J=I1_T,I2_T
3130                   IF(OUTLAT(J).LE.RINLAT(JX)) JINDX1(J) = JX
3131                 ENDDO
3132               ENDDO
3133               DO J=I1_T,I2_T
3134                 JQ = JINDX1(J)
3135                 APHI=OUTLAT(J)
3136                 IF(JQ.GE.1 .AND. JQ .LT. JMXIN) THEN
3137                   J2=JQ+1
3138                   J1=JQ
3139                  DDY(J)=(APHI-RINLAT(J1))/(RINLAT(J2)-RINLAT(J1))
3140                 ELSEIF (JQ .EQ. 0) THEN
3141                   J2=1
3142                   J1=1
3143                   IF(ABS(90.-RINLAT(J1)).GT.0.001) THEN
3144                     DDY(J)=(APHI-RINLAT(J1))/(90.-RINLAT(J1))
3145                   ELSE
3146                     DDY(J)=0.0
3147                   ENDIF
3148                 ELSE
3149                   J2=JMXIN
3150                   J1=JMXIN
3151                   IF(ABS(-90.-RINLAT(J1)).GT.0.001) THEN
3152                     DDY(J)=(APHI-RINLAT(J1))/(-90.-RINLAT(J1))
3153                   ELSE
3154                     DDY(J)=0.0
3155                   ENDIF
3156                 ENDIF
3157                 JINDX1(J)=J1
3158                 JINDX2(J)=J2
3159               ENDDO
3160             ELSE
3161               DO J=I1_T,I2_T
3162                 JINDX1(J) = JMXIN+1
3163               ENDDO
3164               DO JX=JMXIN,1,-1
3165                 DO J=I1_T,I2_T
3166                   IF(OUTLAT(J).LE.RINLAT(JX)) JINDX1(J) = JX
3167                 ENDDO
3168               ENDDO
3169               DO J=I1_T,I2_T
3170                 JQ = JINDX1(J)
3171                 APHI=OUTLAT(J)
3172                 IF(JQ.GT.1 .AND. JQ .LE. JMXIN) THEN
3173                   J2=JQ
3174                   J1=JQ-1
3175                   DDY(J)=(APHI-RINLAT(J1))/(RINLAT(J2)-RINLAT(J1))
3176                 ELSEIF (JQ .EQ. 1) THEN
3177                   J2=1
3178                   J1=1
3179                   IF(ABS(-90.-RINLAT(J1)).GT.0.001) THEN
3180                      DDY(J)=(APHI-RINLAT(J1))/(-90.-RINLAT(J1))
3181                   ELSE
3182                      DDY(J)=0.0
3183                   ENDIF
3184                 ELSE
3185                   J2=JMXIN
3186                   J1=JMXIN
3187                   IF(ABS(90.-RINLAT(J1)).GT.0.001) THEN
3188                      DDY(J)=(APHI-RINLAT(J1))/(90.-RINLAT(J1))
3189                   ELSE
3190                      DDY(J)=0.0
3191                   ENDIF
3192                 ENDIF
3193                 JINDX1(J)=J1
3194                 JINDX2(J)=J2
3195               ENDDO
3196             ENDIF
3197     !
3198     !     if (me .eq. 0 .and. inttyp .eq. 1) then
3199     !       PRINT *,'LA2GA'
3200     !       PRINT *,'IINDX1'
3201     !       PRINT *,(IINDX1(N),N=1,LEN)
3202     !       PRINT *,'IINDX2'
3203     !       PRINT *,(IINDX2(N),N=1,LEN)
3204     !       PRINT *,'JINDX1'
3205     !       PRINT *,(JINDX1(N),N=1,LEN)
3206     !       PRINT *,'JINDX2'
3207     !       PRINT *,(JINDX2(N),N=1,LEN)
3208     !       PRINT *,'DDY'
3209     !       PRINT *,(DDY(N),N=1,LEN)
3210     !       PRINT *,'DDX'
3211     !       PRINT *,(DDX(N),N=1,LEN)
3212     !     endif
3213     !
3214             SUM1 = 0.
3215             SUM2 = 0.
3216             SUM3 = 0.
3217             SUM4 = 0.
3218             IF (LMASK) THEN
3219               WEI1 = 0.
3220               WEI2 = 0.
3221               WEI3 = 0.
3222               WEI4 = 0.
3223               DO I=1,IMXIN
3224                 SUM1 = SUM1 + REGIN(I,1) * RSLMSK(I,1)
3225                 SUM2 = SUM2 + REGIN(I,JMXIN) * RSLMSK(I,JMXIN)
3226                 WEI1 = WEI1 + RSLMSK(I,1)
3227                 WEI2 = WEI2 + RSLMSK(I,JMXIN)
3228     !
3229                 SUM3 = SUM3 + REGIN(I,1) * (1.0-RSLMSK(I,1))
3230                 SUM4 = SUM4 + REGIN(I,JMXIN) * (1.0-RSLMSK(I,JMXIN))
3231                 WEI3 = WEI3 + (1.0-RSLMSK(I,1))
3232                 WEI4 = WEI4 + (1.0-RSLMSK(I,JMXIN))
3233               ENDDO
3234     !
3235               IF(WEI1.GT.0.) THEN
3236                 SUM1 = SUM1 / WEI1
3237               ELSE
3238                 SUM1 = 0.
3239               ENDIF
3240               IF(WEI2.GT.0.) THEN
3241                 SUM2 = SUM2 / WEI2
3242               ELSE
3243                 SUM2 = 0.
3244               ENDIF
3245               IF(WEI3.GT.0.) THEN
3246                 SUM3 = SUM3 / WEI3
3247               ELSE
3248                 SUM3 = 0.
3249               ENDIF
3250               IF(WEI4.GT.0.) THEN
3251                 SUM4 = SUM4 / WEI4
3252               ELSE
3253                 SUM4 = 0.
3254               ENDIF
3255             ELSE
3256               DO I=1,IMXIN
3257                 SUM1 = SUM1 + REGIN(I,1)
3258                 SUM2 = SUM2 + REGIN(I,JMXIN)
3259               ENDDO
3260               SUM1 = SUM1 / IMXIN
3261               SUM2 = SUM2 / IMXIN
3262               SUM3 = SUM1
3263               SUM4 = SUM2
3264             ENDIF
3265     !
3266     !     print *,' SUM1=',SUM1,' SUM2=',SUM2
3267     !    *,' SUM3=',SUM3,' SUM4=',SUM4
3268     !     print *,' RSLMSK=',(RSLMSK(I,1),I=1,IMXIN)
3269     !     print *,' SLMASK=',(SLMASK(I),I=1,IMXOUT)
3270     !    *,' j1=',jindx1(1),' j2=',jindx2(1)
3271     !
3272     !
3273     !  INTTYP=1  Take the closest point value
3274     !
3275             IF(INTTYP.EQ.1) THEN
3276     
3277               DO I=I1_T,I2_T
3278                 JY = JINDX1(I)
3279                 IF(DDY(I) .GE. 0.5) JY = JINDX2(I)
3280                 IX = IINDX1(I)
3281                 IF(DDX(I) .GE. 0.5) IX = IINDX2(I)
3282     !
3283     !cggg start
3284     !
3285                 if (.not. lmask) then
3286     
3287                   GAUOUT(I) = REGIN(IX,JY)
3288     
3289                 else
3290     
3291                   IF(SLMASK(I).EQ.RSLMSK(IX,JY)) THEN
3292     
3293                     GAUOUT(I) = REGIN(IX,JY)
3294     
3295                   else
3296     
3297                     i1 = ix
3298                     j1 = jy
3299     
3300     ! SPIRAL AROUND UNTIL MATCHING MASK IS FOUND.
3301                     DO NX=1,JMXIN*IMXIN/2
3302                       KXS=SQRT(4*NX-2.5)
3303                       KXT=NX-INT(KXS**2/4+1)
3304                       SELECT CASE(MOD(KXS,4))
3305                       CASE(1)
3306                         IX=I1-KXS/4+KXT
3307                         JX=J1-KXS/4
3308                       CASE(2)
3309                         IX=I1+1+KXS/4
3310                         JX=J1-KXS/4+KXT
3311                       CASE(3)
3312                         IX=I1+1+KXS/4-KXT
3313                         JX=J1+1+KXS/4
3314                       CASE DEFAULT
3315                         IX=I1-KXS/4
3316                         JX=J1+KXS/4-KXT
3317                       END SELECT
3318                       IF(JX.LT.1) THEN
3319                         IX=IX+IMXIN/2
3320                         JX=2-JX
3321                       ELSEIF(JX.GT.JMXIN) THEN
3322                         IX=IX+IMXIN/2
3323                         JX=2*JMXIN-JX
3324                       ENDIF
3325                       IX=MODULO(IX-1,IMXIN)+1
3326                       IF(SLMASK(I).EQ.RSLMSK(IX,JX)) THEN
3327                         GAUOUT(I) = REGIN(IX,JX)
3328                         GO TO 81
3329                       ENDIF
3330                     ENDDO
3331     
3332     !cggg here, set the gauout value to be 0, and let's sarah's land
3333     !cggg routine assign a default.
3334     
3335                   print*,'no matching mask found ',i,i1,j1,ix,jx
3336                   print*,'set to default value.'
3337                   gauout(i) = 0.0
3338     
3339     
3340        81  continue
3341     
3342                   end if
3343     
3344                 end if
3345     
3346     !cggg end
3347     
3348               ENDDO
3349               KMAMI=1
3350               if (me .eq. 0) CALL MAXMIN(GAUOUT(I1_T),LEN_THREAD,KMAMI)
3351               CYCLE
3352             ENDIF  ! nearest neighbor interpolation
3353     
3354     !
3355     !  QUASI-BILINEAR INTERPOLATION
3356     !
3357             IFILL = 0
3358             IMXNX = 0
3359             DO I=I1_T,I2_T
3360               Y  = DDY(I)
3361               J1 = JINDX1(I)
3362               J2 = JINDX2(I)
3363               X  = DDX(I)
3364               I1 = IINDX1(I)
3365               I2 = IINDX2(I)
3366     !
3367               WI1J1 = (1.-X) * (1.-Y)
3368               WI2J1 =     X  *( 1.-Y)
3369               WI1J2 = (1.-X) *      Y
3370               WI2J2 =     X  *      Y
3371     !
3372               TEM = 4.*SLMASK(I) - RSLMSK(I1,J1) - RSLMSK(I2,J1)
3373          &                       - RSLMSK(I1,J2) - RSLMSK(I2,J2)
3374               IF(LMASK .AND. ABS(TEM) .GT. 0.01) THEN
3375                 IF(SLMASK(I).EQ.1.) THEN
3376                     WI1J1 = WI1J1 * RSLMSK(I1,J1)
3377                     WI2J1 = WI2J1 * RSLMSK(I2,J1)
3378                     WI1J2 = WI1J2 * RSLMSK(I1,J2)
3379                     WI2J2 = WI2J2 * RSLMSK(I2,J2)
3380                 ELSE
3381                     WI1J1 = WI1J1 * (1.0-RSLMSK(I1,J1))
3382                     WI2J1 = WI2J1 * (1.0-RSLMSK(I2,J1))
3383                     WI1J2 = WI1J2 * (1.0-RSLMSK(I1,J2))
3384                     WI2J2 = WI2J2 * (1.0-RSLMSK(I2,J2))
3385                 ENDIF
3386               ENDIF
3387     !
3388               WSUM   = WI1J1 + WI2J1 + WI1J2 + WI2J2
3389               WRK(I) = WSUM
3390               IF(WSUM.NE.0.) THEN
3391                 WSUMIV = 1./WSUM
3392     !
3393                 IF(J1.NE.J2) THEN
3394                   GAUOUT(I) = (WI1J1*REGIN(I1,J1) + WI2J1*REGIN(I2,J1) +
3395          &                     WI1J2*REGIN(I1,J2) + WI2J2*REGIN(I2,J2))
3396          &                  *WSUMIV
3397                 ELSE
3398     !
3399                   IF (RLAT .GT. 0.0) THEN
3400                     IF (SLMASK(I) .EQ. 1.0) THEN
3401                       SUMN = SUM1
3402                       SUMS = SUM2
3403                     ELSE
3404                       SUMN = SUM3
3405                       SUMS = SUM4
3406                     ENDIF
3407                     IF( J1 .EQ. 1) THEN
3408                       GAUOUT(I) = (WI1J1*SUMN        +WI2J1*SUMN        +
3409          &                         WI1J2*REGIN(I1,J2)+WI2J2*REGIN(I2,J2))
3410          &                      * WSUMIV
3411                     ELSEIF (J1 .EQ. JMXIN) THEN
3412                       GAUOUT(I) = (WI1J1*REGIN(I1,J1)+WI2J1*REGIN(I2,J1)+
3413          &                         WI1J2*SUMS        +WI2J2*SUMS        )
3414          &                      * WSUMIV
3415                     ENDIF
3416     !     print *,' slmask=',slmask(i),' sums=',sums,' sumn=',sumn
3417     !    &,' regin=',regin(i1,j2),regin(i2,j2),' j1=',j1,' j2=',j2
3418     !    &,' wij=',wi1j1, wi2j1, wi1j2, wi2j2,wsumiv
3419                   ELSE
3420                     IF (SLMASK(I) .EQ. 1.0) THEN
3421                       SUMS = SUM1
3422                       SUMN = SUM2
3423                     ELSE
3424                       SUMS = SUM3
3425                       SUMN = SUM4
3426                     ENDIF
3427                     IF( J1 .EQ. 1) THEN
3428                       GAUOUT(I) = (WI1J1*REGIN(I1,J1)+WI2J1*REGIN(I2,J1)+
3429          &                         WI1J2*SUMS        +WI2J2*SUMS        )
3430          &                      * WSUMIV
3431                     ELSEIF (J1 .EQ. JMXIN) THEN
3432                       GAUOUT(I) = (WI1J1*SUMN        +WI2J1*SUMN        +
3433          &                         WI1J2*REGIN(I1,J2)+WI2J2*REGIN(I2,J2))
3434          &                      * WSUMIV
3435                     ENDIF
3436                   ENDIF
3437                 ENDIF            ! if j1 .ne. j2
3438               ENDIF
3439             ENDDO
3440             DO I=I1_T,I2_T
3441               J1 = JINDX1(I)
3442               J2 = JINDX2(I)
3443               I1 = IINDX1(I)
3444               I2 = IINDX2(I)
3445               IF(WRK(I) .EQ. 0.0) THEN
3446                 IF(.NOT.LMASK) THEN
3447                   WRITE(6,*) ' LA2GA called with LMASK=.TRUE. but bad',
3448          &                   ' RSLMSK or SLMASK given'
3449                   CALL ABORT
3450                 ENDIF
3451                 IFILL = IFILL + 1
3452                 IF(IFILL.LE.2) THEN
3453                   if (me .eq. 0) then
3454                     WRITE(6,*) 'I1,I2,J1,J2=',I1,I2,J1,J2
3455                     WRITE(6,*) 'RSLMSK=',RSLMSK(I1,J1),RSLMSK(I1,J2),
3456          &                               RSLMSK(I2,J1),RSLMSK(I2,J2)
3457     !               WRITE(6,*) 'I,J=',I,J,' SLMASK(I)=',SLMASK(I)
3458                     WRITE(6,*) 'I=',I,' SLMASK(I)=',SLMASK(I)
3459          &,         ' outlon=',outlon(i),' outlat=',outlat(i)
3460                   endif
3461                 ENDIF
3462     ! SPIRAL AROUND UNTIL MATCHING MASK IS FOUND.
3463                 DO NX=1,JMXIN*IMXIN/2
3464                   KXS=SQRT(4*NX-2.5)
3465                   KXT=NX-INT(KXS**2/4+1)
3466                   SELECT CASE(MOD(KXS,4))
3467                   CASE(1)
3468                     IX=I1-KXS/4+KXT
3469                     JX=J1-KXS/4
3470                   CASE(2)
3471                     IX=I1+1+KXS/4
3472                     JX=J1-KXS/4+KXT
3473                   CASE(3)
3474                     IX=I1+1+KXS/4-KXT
3475                     JX=J1+1+KXS/4
3476                   CASE DEFAULT
3477                     IX=I1-KXS/4
3478                     JX=J1+KXS/4-KXT
3479                   END SELECT
3480                   IF(JX.LT.1) THEN
3481                     IX=IX+IMXIN/2
3482                     JX=2-JX
3483                   ELSEIF(JX.GT.JMXIN) THEN
3484                     IX=IX+IMXIN/2
3485                     JX=2*JMXIN-JX
3486                   ENDIF
3487                   IX=MODULO(IX-1,IMXIN)+1
3488                   IF(SLMASK(I).EQ.RSLMSK(IX,JX)) THEN
3489                     GAUOUT(I) = REGIN(IX,JX)
3490                     IMXNX=MAX(IMXNX,NX)
3491                     GO TO 71
3492                   ENDIF
3493                 ENDDO
3494     !
3495                 WRITE(6,*) ' ERROR!!! No filling value found in LA2GA'
3496     !           WRITE(6,*) ' I IX JX SLMASK(I) RSLMSK ',
3497     !    &                   I,IX,JX,SLMASK(I),RSLMSK(IX,JX)
3498                 CALL ABORT
3499     !
3500        71       CONTINUE
3501               ENDIF
3502     !
3503             ENDDO
3504           ENDDO            ! END OF THREADED LOOP ...................
3505     !$OMP END PARALLEL DO
3506     !
3507           IF(IFILL.GT.1) THEN
3508             if (me .eq. 0) then
3509             WRITE(6,*) ' Unable to interpolate.  Filled with nearest',
3510          &             ' point value at ',IFILL,' points  imxnx=',imxnx
3511             endif
3512           ENDIF
3513     !
3514           KMAMI=1
3515           if (me .eq. 0) CALL MAXMIN(GAUOUT,LEN,KMAMI)
3516     !
3517           RETURN
3518           END SUBROUTINE LA2GA
3519           SUBROUTINE MAXMIN(F,IMAX,KMAX)
3520           USE MACHINE , ONLY : kind_io8,kind_io4
3521           implicit none
3522           integer i,iimin,iimax,kmax,imax,k
3523           REAL (KIND=KIND_IO8) fmin,fmax
3524     !
3525           REAL (KIND=KIND_IO8) F(IMAX,KMAX)
3526     !
3527           DO K=1,KMAX
3528     !
3529             FMAX = F(1,K)
3530             FMIN = F(1,K)
3531     !
3532             DO I=1,IMAX
3533               IF(FMAX.LE.F(I,K)) THEN
3534                 FMAX  = F(I,K)
3535                 IIMAX = I
3536               ENDIF
3537               IF(FMIN.GE.F(I,K)) THEN
3538                 FMIN  = F(I,K)
3539                 IIMIN = I
3540               ENDIF
3541             ENDDO
3542     !
3543           WRITE(6,100) K,FMAX,IIMAX,FMIN,IIMIN
3544       100 FORMAT(2X,'LEVEL=',I2,' MAX=',E10.4,' AT I=',I5,
3545          &                      ' MIN=',E10.4,' AT I=',I5)
3546     !
3547           ENDDO
3548     !
3549           RETURN
3550           END
3551           SUBROUTINE FILANL(TSFANL,TSFAN2,WETANL,SNOANL,ZORANL,ALBANL,
3552          &                  AISANL,
3553          &                  TG3ANL,CVANL ,CVBANL,CVTANL,
3554          &                  CNPANL,SMCANL,STCANL,SLIANL,SCVANL,VEGANL,
3555          &                  vetanl,sotanl,ALFANL,
3556     !Cwu [+1L] add ()anl for sih, sic
3557          &                  SIHANL,SICANL,
3558     !Clu [+1L] add ()anl for vmn, vmx, slp, abs
3559          &                  VMNANL,VMXANL,SLPANL,ABSANL,
3560          &                  TSFCLM,TSFCL2,WETCLM,SNOCLM,ZORCLM,ALBCLM,
3561          &                  AISCLM,
3562          &                  TG3CLM,CVCLM ,CVBCLM,CVTCLM,
3563          &                  CNPCLM,SMCCLM,STCCLM,SLICLM,SCVCLM,VEGCLM,
3564          &                  vetclm,sotclm,ALFCLM,
3565     !Cwu [+1L] add ()clm for sih, sic
3566          &                  SIHCLM,SICCLM,
3567     !Clu [+1L] add ()clm for vmn, vmx, slp, abs
3568          &                  VMNCLM,VMXCLM,SLPCLM,ABSCLM,
3569          &                  LEN,LSOIL)
3570           USE MACHINE , ONLY : kind_io8,kind_io4
3571           implicit none
3572           integer i,j,len,lsoil
3573     !
3574           REAL (KIND=KIND_IO8) TSFANL(LEN),TSFAN2(LEN),WETANL(LEN),
3575          &     SNOANL(LEN),
3576          &     ZORANL(LEN),ALBANL(LEN,4),AISANL(LEN),
3577          &     TG3ANL(LEN),
3578          &     CVANL (LEN),CVBANL(LEN),CVTANL(LEN),
3579          &     CNPANL(LEN),
3580          &     SMCANL(LEN,LSOIL),STCANL(LEN,LSOIL),
3581          &     SLIANL(LEN),SCVANL(LEN),VEGANL(LEN),
3582          &     vetanl(LEN),sotanl(LEN),ALFANL(LEN,2)
3583     !Cwu [+1L] add ()anl for sih, sic
3584          &,    SIHANL(LEN),SICANL(LEN)
3585     !Clu [+1L] add ()anl for vmn, vmx, slp, abs
3586          &,    VMNANL(LEN),VMXANL(LEN),SLPANL(LEN),ABSANL(LEN)
3587           REAL (KIND=KIND_IO8) TSFCLM(LEN),TSFCL2(LEN),WETCLM(LEN),
3588          &     SNOCLM(LEN),
3589          &     ZORCLM(LEN),ALBCLM(LEN,4),AISCLM(LEN),
3590          &     TG3CLM(LEN),
3591          &     CVCLM (LEN),CVBCLM(LEN),CVTCLM(LEN),
3592          &     CNPCLM(LEN),
3593          &     SMCCLM(LEN,LSOIL),STCCLM(LEN,LSOIL),
3594          &     SLICLM(LEN),SCVCLM(LEN),VEGCLM(LEN),
3595          &     vetclm(LEN),sotclm(LEN),ALFCLM(LEN,2)
3596     !Cwu [+1L] add ()clm for sih, sic
3597          &,    SIHCLM(LEN),SICCLM(LEN)
3598     !Clu [+1L] add ()clm for vmn, vmx, slp, abs
3599          &,    VMNCLM(LEN),VMXCLM(LEN),SLPCLM(LEN),ABSCLM(LEN)
3600     !
3601           DO I=1,LEN
3602             TSFANL(I)   = TSFCLM(I)      !  Tsf at t
3603             TSFAN2(I)   = TSFCL2(I)      !  Tsf at t-deltsfc
3604             WETANL(I)   = WETCLM(I)      !  Soil Wetness
3605             SNOANL(I)   = SNOCLM(I)      !  SNOW
3606             SCVANL(I)   = SCVCLM(I)      !  SNOW COVER
3607             AISANL(I)   = AISCLM(I)      !  SEAICE
3608             SLIANL(I)   = SLICLM(I)      !  LAND/SEA/SNOW mask
3609             ZORANL(I)   = ZORCLM(I)      !  Surface roughness
3610     !       PLRANL(I)   = PLRCLM(I)      !  Maximum stomatal resistance
3611             TG3ANL(I)   = TG3CLM(I)      !  Deep soil temperature
3612             CNPANL(I)   = CNPCLM(I)      !  Canopy water content
3613             VEGANL(I)   = VEGCLM(I)      !  Vegetation cover
3614             VEtANL(I)   = VEtCLM(I)      !  Vegetation type
3615             sotANL(I)   = sotCLM(I)      !  Soil type
3616             CVANL(I)    = CVCLM(I)       !  CV
3617             CVBANL(I)   = CVBCLM(I)      !  CVB
3618             CVTANL(I)   = CVTCLM(I)      !  CVT
3619     !Cwu [+4L] add sih, sic
3620             SIHANL(I)   = SIHCLM(I)      !  Sea ice thickness
3621             SICANL(I)   = SICCLM(I)      !  Sea ice concentration
3622     !Clu [+4L] add vmn, vmx, slp, abs
3623             VMNANL(I)   = VMNCLM(I)      !  Min vegetation cover
3624             VMXANL(I)   = VMXCLM(I)      !  Max vegetation cover 
3625             SLPANL(I)   = SLPCLM(I)      !  slope type
3626             ABSANL(I)   = ABSCLM(I)      !  Max snow albedo
3627           ENDDO
3628     !
3629           DO J=1,LSOIL
3630             DO I=1,LEN
3631               SMCANL(I,J) = SMCCLM(I,J)  !   Layer soil wetness
3632               STCANL(I,J) = STCCLM(I,J)  !   Soil temperature
3633             ENDDO
3634           ENDDO
3635           DO J=1,4
3636             DO I=1,LEN
3637               ALBANL(I,J) = ALBCLM(I,J)  !  Albedo
3638             ENDDO
3639           ENDDO
3640           DO J=1,2
3641             DO I=1,LEN
3642               ALFANL(I,J) = ALFCLM(I,J)  !  Vegetation fraction for Albedo
3643             ENDDO
3644           ENDDO
3645     !
3646           RETURN
3647           END
3648           SUBROUTINE ANALY(LUGB,IY,IM,ID,IH,FH,LEN,LSOIL,
3649          &                 SLMASK,FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
3650          &                 FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,FNVEGA,
3651          &                 fnveta,fnsota,
3652     !Clu [+1L] add fn()a for vmn, vmx, slp, abs
3653          &                 FNVMNA,FNVMXA,FNSLPA,FNABSA,
3654          &                 TSFANL,WETANL,SNOANL,ZORANL,ALBANL,AISANL,
3655          &                 TG3ANL,CVANL ,CVBANL,CVTANL,
3656          &                 SMCANL,STCANL,SLIANL,SCVANL,ACNANL,VEGANL,
3657          &                 vetanl,sotanl,ALFANL,TSFAN0,
3658     !Clu [+1L] add ()anl for vmn, vmx, slp, abs
3659          &                 VMNANL,VMXANL,SLPANL,ABSANL,
3660     !cggg snow mods start    &        KPDTSF,KPDWET,KPDSNO,KPDZOR,KPDALB,KPDAIS,
3661          &                 KPDTSF,KPDWET,KPDSNO,KPDSND,KPDZOR,KPDALB,KPDAIS,
3662     !cggg snow mods end
3663          &                 KPDTG3,KPDSCV,KPDACN,KPDSMC,KPDSTC,KPDVEG,
3664          &                 kprvet,kpdsot,kpdalf,
3665     !Clu [+1L] add kpd() for vmn, vmx, slp, abs
3666          &                 KPDVMN,KPDVMX,KPDSLP,KPDABS,
3667          &                 IRTTSF,IRTWET,IRTSNO,IRTZOR,IRTALB,IRTAIS,
3668          &                 IRTTG3,IRTSCV,IRTACN,IRTSMC,IRTSTC,IRTVEG,
3669          &                 irtvet,irtsot,irtalf
3670     !Clu [+1L] add irt() for vmn, vmx, slp, abs
3671          &,                IRTVMN,IRTVMX,IRTSLP,IRTABS
3672          &,                IMSK, JMSK, SLMSKH, OUTLAT, OUTLON
3673          &,                GAUS, BLNO, BLTO, me)
3674           USE MACHINE , ONLY : kind_io8,kind_io4
3675           implicit none
3676           integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno,
3677          &        irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot,
3678     !cggg snow mods start     & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy,
3679          &        imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy,
3680     !cggg snow mods end
3681          &        lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc,
3682          &        kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j
3683     !Clu [+1L] add kpd() and irt() for vmn, vmx, slp, abs
3684          &,       kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs
3685           REAL (KIND=KIND_IO8) blto,blno,fh
3686     !
3687           REAL (KIND=KIND_IO8)    SLMASK(LEN)
3688           REAL (KIND=KIND_IO8)    SLMSKH(IMSK,JMSK)
3689           REAL (KIND=KIND_IO8)    OUTLAT(LEN), OUTLON(LEN)
3690           INTEGER kpdalb(4),   kpdalf(2)
3691     !cggg snow mods start
3692           INTEGER KPDS(1000),KGDS(1000),JPDS(1000),JGDS(1000)
3693           INTEGER LUGI, LSKIP, LGRIB, NDATA
3694     !cggg snow mods end
3695     !
3696           CHARACTER*500 FNTSFA,FNWETA,FNSNOA,FNZORA,FNALBA,FNAISA,
3697          &             FNTG3A,FNSCVA,FNSMCA,FNSTCA,FNACNA,FNVEGA,
3698          &             fnveta,fnsota
3699     !Clu [+1L] add fn()a for vmn, vmx, slp, abs
3700          &,            FNVMNA,FNVMXA,FNSLPA,FNABSA
3701     
3702           REAL (KIND=KIND_IO8) TSFANL(LEN), WETANL(LEN),   SNOANL(LEN),
3703          &     ZORANL(LEN), ALBANL(LEN,4), AISANL(LEN),
3704          &     TG3ANL(LEN), ACNANL(LEN),
3705          &     CVANL (LEN), CVBANL(LEN),   CVTANL(LEN),
3706          &     SLIANL(LEN), SCVANL(LEN),   VEGANL(LEN),
3707          &     vetanl(LEN), sotanl(LEn),   ALFANL(LEN,2),
3708          &     SMCANL(LEN,LSOIL), STCANL(LEN,LSOIL),
3709          &     TSFAN0(LEN)
3710     !Clu [+1L] add ()anl for vmn, vmx, slp, abs
3711          &,    VMNANL(LEN),VMXANL(LEN),SLPANL(LEN),ABSANL(LEN)
3712     !
3713           LOGICAL GAUS
3714     !
3715     ! TSF
3716     !
3717           IRTTSF=0
3718           IF(FNTSFA(1:8).NE.'        ') THEN
3719             CALL FIXRDA(LUGB,FNTSFA,KPDTSF,SLMASK,
3720          &             IY,IM,ID,IH,FH,TSFANL,LEN,IRET
3721          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3722          &,            OUTLAT, OUTLON, me)
3723             IRTTSF=IRET
3724             IF(IRET.EQ.1) THEN
3725               WRITE(6,*) 'T SURFACE ANALYSIS READ ERROR'
3726               CALL ABORT
3727             ELSEIF(IRET.EQ.-1) THEN
3728               if (me .eq. 0) then
3729               PRINT *,'OLD T SURFACE ANALYSIS PROVIDED, Indicating proper',
3730          &            ' file name is given.  No error suspected.'
3731               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
3732               endif
3733             ELSE
3734               if (me .eq. 0) PRINT *,'T SURFACE ANALYSIS PROVIDED.'
3735             ENDIF
3736           ELSE
3737             if (me .eq. 0) then
3738     !       PRINT *,'************************************************'
3739             PRINT *,'NO TSF ANALYSIS AVAILABLE.  CLIMATOLOGY USED'
3740             endif
3741           ENDIF
3742     !
3743     ! TSF0
3744     !
3745     !     IF(FNTSFA(1:8).NE.'        ') THEN
3746     !       CALL FIXRDA(LUGB,FNTSFA,KPDTSF,SLMASK,
3747     !    &             IY,IM,ID,IH,0.,TSFAN0,LEN,IRET
3748     !    &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3749     !    &,            OUTLAT, OUTLON, me)
3750     !       IF(IRET.EQ.1) THEN
3751     !         WRITE(6,*) 'T SURFACE AT FT=0 ANALYSIS READ ERROR'
3752     !         CALL ABORT
3753     !       ELSEIF(IRET.EQ.-1) THEN
3754     !         WRITE(6,*) 'COULD NOT FIND T SURFACE ANALYSIS AT FT=0'
3755     !         CALL ABORT
3756     !       ELSE
3757     !         PRINT *,'T SURFACE ANALYSIS AT FT=0 FOUND.'
3758     !       ENDIF
3759     !     ELSE
3760     !       DO I=1,LEN
3761     !         TSFAN0(I)=-999.9
3762     !       ENDDO
3763     !     ENDIF
3764     !
3765     !  ALBEDO
3766     !
3767           IF(FNALBA(1:8).NE.'        ') THEN
3768             DO KK = 1, 4
3769               IRTALB=0
3770               CALL FIXRDA(LUGB,FNALBA,KPDALB(KK),SLMASK,
3771          &               IY,IM,ID,IH,FH,ALBANL(1,KK),LEN,IRET
3772          &,              IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3773          &,              OUTLAT, OUTLON, me)
3774               IRTALB=IRET
3775               IF(IRET.EQ.1) THEN
3776                 WRITE(6,*) 'ALBEDO ANALYSIS READ ERROR'
3777                 CALL ABORT
3778               ELSEIF(IRET.EQ.-1) THEN
3779                 if (me .eq. 0) then
3780                 PRINT *,'OLD ALBEDO ANALYSIS PROVIDED, Indicating proper',
3781          &              ' file name is given.  No error suspected.'
3782                 WRITE(6,*) 'FORECAST GUESS WILL BE USED'
3783                 endif
3784               ELSE
3785                 if (me .eq. 0 .and. kk .eq. 4)
3786          &                  PRINT *,'ALBEDO ANALYSIS PROVIDED.'
3787               ENDIF
3788             ENDDO
3789           ELSE
3790             if (me .eq. 0) then
3791     !       PRINT *,'************************************************'
3792             PRINT *,'NO ALBEDO ANALYSIS AVAILABLE.  CLIMATOLOGY USED'
3793             endif
3794           ENDIF
3795     !
3796     !  Vegetation Fraction for albedo
3797     !
3798           IF(FNALBA(1:8).NE.'        ') THEN
3799             DO KK = 1, 2
3800               IRTALF=0
3801               CALL FIXRDA(LUGB,FNALBA,KPDALF(KK),SLMASK,
3802          &               IY,IM,ID,IH,FH,ALFANL(1,KK),LEN,IRET
3803          &,              IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3804          &,              OUTLAT, OUTLON, me)
3805               IRTALF=IRET
3806               IF(IRET.EQ.1) THEN
3807                 WRITE(6,*) 'ALBEDO ANALYSIS READ ERROR'
3808                 CALL ABORT
3809               ELSEIF(IRET.EQ.-1) THEN
3810                 if (me .eq. 0) then
3811                 PRINT *,'OLD ALBEDO ANALYSIS PROVIDED, Indicating proper',
3812          &              ' file name is given.  No error suspected.'
3813                 WRITE(6,*) 'FORECAST GUESS WILL BE USED'
3814                 endif
3815               ELSE
3816                 if (me .eq. 0 .and. kk .eq. 4)
3817          &                  PRINT *,'ALBEDO ANALYSIS PROVIDED.'
3818               ENDIF
3819             ENDDO
3820           ELSE
3821             if (me .eq. 0) then
3822     !       PRINT *,'************************************************'
3823             PRINT *,'NO VEGFALBEDO ANALYSIS AVAILABLE.  CLIMATOLOGY USED'
3824             endif
3825           ENDIF
3826     !
3827     !  Soil Wetness
3828     !
3829           IRTWET=0
3830           IRTSMC=0
3831           IF(FNWETA(1:8).NE.'        ') THEN
3832             CALL FIXRDA(LUGB,FNWETA,KPDWET,SLMASK,
3833          &             IY,IM,ID,IH,FH,WETANL,LEN,IRET
3834          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3835          &,            OUTLAT, OUTLON, me)
3836             IRTWET=IRET
3837             IF(IRET.EQ.1) THEN
3838               WRITE(6,*) 'BUCKET WETNESS ANALYSIS READ ERROR'
3839               CALL ABORT
3840             ELSEIF(IRET.EQ.-1) THEN
3841               if (me .eq. 0) then
3842               PRINT *,'OLD WETNESS ANALYSIS PROVIDED, Indicating proper',
3843          &            ' file name is given.  No error suspected.'
3844               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
3845               endif
3846             ELSE
3847               if (me .eq. 0) PRINT *,'BUCKET WETNESS ANALYSIS PROVIDED.'
3848             ENDIF
3849           ELSEIF(FNSMCA(1:8).NE.'        ') THEN
3850             CALL FIXRDA(LUGB,FNSMCA,KPDSMC,SLMASK,
3851          &             IY,IM,ID,IH,FH,SMCANL(1,1),LEN,IRET
3852          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3853          &,            OUTLAT, OUTLON, me)
3854             CALL FIXRDA(LUGB,FNSMCA,KPDSMC,SLMASK,
3855          &             IY,IM,ID,IH,FH,SMCANL(1,2),LEN,IRET
3856          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3857          &,            OUTLAT, OUTLON, me)
3858             IRTSMC=IRET
3859             IF(IRET.EQ.1) THEN
3860               WRITE(6,*) 'LAYER SOIL WETNESS ANALYSIS READ ERROR'
3861               CALL ABORT
3862             ELSEIF(IRET.EQ.-1) THEN
3863               if (me .eq. 0) then
3864               PRINT *,'OLD LAYER SOIL WETNESS ANALYSIS PROVIDED',
3865          &            ' Indicating proper file name is given.'
3866               PRINT *,' No error suspected.'
3867               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
3868               endif
3869             ELSE
3870               if (me .eq. 0) PRINT *,'LAYER SOIL WETNESS ANALYSIS PROVIDED.'
3871             ENDIF
3872           ELSE
3873             if (me .eq. 0) then
3874     !       PRINT *,'************************************************'
3875             PRINT *,'NO SOIL WETNESS ANALYSIS AVAILABLE.  CLIMATOLOGY USED'
3876             endif
3877           ENDIF
3878     !
3879     !  READ IN SNOW DEPTH/SNOW COVER
3880     !
3881           IRTSCV=0
3882           IF(FNSNOA(1:8).NE.'        ') THEN
3883             DO I=1,LEN
3884               SCVANL(I)=0.
3885             ENDDO
3886     !cggg snow mods start
3887     !cggg need to determine if the snow data is on the gaussian grid
3888     !cggg or not.  if gaussian, then data is a depth, not liq equiv
3889     !cggg depth. if not gaussian, then data is from hua-lu's
3890     !cggg program and is a liquid equiv.  need to communicate
3891     !cggg this to routine fixrda via the 3rd argument which is
3892     !cggg the grib parameter id number.
3893             CALL BAOPENR(LUGB,FNSNOA,IRET)
3894             IF (IRET .NE. 0) THEN
3895               WRITE(6,*) ' ERROR IN OPENING FILE ',trim(FNSNOA)
3896               PRINT *,'ERROR IN OPENING FILE ',trim(FNSNOA)
3897               CALL ABORT
3898             ENDIF
3899             LUGI=0
3900             lskip=-1
3901             JPDS=-1
3902             JGDS=-1
3903             KPDS=JPDS
3904             CALL GETGBH(LUGB,LUGI,LSKIP,JPDS,JGDS,LGRIB,NDATA,
3905          &              LSKIP,KPDS,KGDS,IRET)
3906             CLOSE(LUGB)
3907             IF (IRET .NE. 0) THEN
3908               WRITE(6,*) ' ERROR READING HEADER OF FILE: ',trim(FNSNOA)
3909               PRINT *,'ERROR READING HEADER OF FILE: ',trim(FNSNOA)
3910               CALL ABORT
3911             ENDIF
3912             IF (KGDS(1) == 4) THEN  ! GAUSSIAN DATA IS DEPTH
3913               CALL FIXRDA(LUGB,FNSNOA,KPDSND,SLMASK,
3914          &                IY,IM,ID,IH,FH,SNOANL,LEN,IRET
3915          &,               IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3916          &,               OUTLAT, OUTLON, me)
3917               SNOANL=SNOANL*100.  ! CONVERT FROM METERS TO LIQ. EQ.
3918                                   ! DEPTH IN MM USING 10:1 RATIO
3919             ELSE                    ! LAT/LON DATA IS LIQ EQUV. DEPTH
3920               CALL FIXRDA(LUGB,FNSNOA,KPDSNO,SLMASK,
3921          &                IY,IM,ID,IH,FH,SNOANL,LEN,IRET
3922          &,               IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3923          &,               OUTLAT, OUTLON, me)
3924             ENDIF
3925     !cggg snow mods end
3926             IRTSCV=IRET
3927             IF(IRET.EQ.1) THEN
3928               WRITE(6,*) 'SNOW DEPTH ANALYSIS READ ERROR'
3929               CALL ABORT
3930             ELSEIF(IRET.EQ.-1) THEN
3931               if (me .eq. 0) then
3932               PRINT *,'OLD SNOW DEPTH ANALYSIS PROVIDED, Indicating proper',
3933          &            ' file name is given.  No error suspected.'
3934               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
3935               endif
3936             ELSE
3937               if (me .eq. 0) PRINT *,'SNOW DEPTH ANALYSIS PROVIDED.'
3938             ENDIF
3939             IRTSNO=0
3940           ELSEIF(FNSCVA(1:8).NE.'        ') THEN
3941             DO I=1,LEN
3942               SNOANL(I)=0.
3943             ENDDO
3944             CALL FIXRDA(LUGB,FNSCVA,KPDSCV,SLMASK,
3945          &             IY,IM,ID,IH,FH,SCVANL,LEN,IRET
3946          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3947          &,            OUTLAT, OUTLON, me)
3948             IRTSNO=IRET
3949             IF(IRET.EQ.1) THEN
3950               WRITE(6,*) 'SNOW COVER ANALYSIS READ ERROR'
3951               CALL ABORT
3952             ELSEIF(IRET.EQ.-1) THEN
3953               if (me .eq. 0) then
3954               PRINT *,'OLD SNOW COVER ANALYSIS PROVIDED, Indicating proper',
3955          &            ' file name is given.  No error suspected.'
3956               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
3957               endif
3958             ELSE
3959               if (me .eq. 0) PRINT *,'SNOW COVER ANALYSIS PROVIDED.'
3960             ENDIF
3961           ELSE
3962             if (me .eq. 0) then
3963     !       PRINT *,'************************************************'
3964             PRINT *,'NO SNOW/SNOCOV ANALYSIS AVAILABLE.  CLIMATOLOGY USED'
3965             endif
3966           ENDIF
3967     !
3968     !  Sea ice mask
3969     !
3970           IRTACN=0
3971           IRTAIS=0
3972           IF(FNACNA(1:8).NE.'        ') THEN
3973             CALL FIXRDA(LUGB,FNACNA,KPDACN,SLMASK,
3974          &             IY,IM,ID,IH,FH,ACNANL,LEN,IRET
3975          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3976          &,            OUTLAT, OUTLON, me)
3977             IRTACN=IRET
3978             IF(IRET.EQ.1) THEN
3979               WRITE(6,*) 'ICE CONCENTRATION ANALYSIS READ ERROR'
3980               CALL ABORT
3981             ELSEIF(IRET.EQ.-1) THEN
3982               if (me .eq. 0) then
3983               PRINT *,'OLD ICE CONCENTRATION ANALYSIS PROVIDED',
3984          &            ' Indicating proper file name is given'
3985               PRINT *,' No error suspected.'
3986               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
3987               endif
3988             ELSE
3989               if (me .eq. 0) PRINT *,'ICE CONCENTRATION ANALYSIS PROVIDED.'
3990             ENDIF
3991           ELSEIF(FNAISA(1:8).NE.'        ') THEN
3992             CALL FIXRDA(LUGB,FNAISA,KPDAIS,SLMASK,
3993          &             IY,IM,ID,IH,FH,AISANL,LEN,IRET
3994          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
3995          &,            OUTLAT, OUTLON, me)
3996             IRTAIS=IRET
3997             IF(IRET.EQ.1) THEN
3998               WRITE(6,*) 'ICE MASK ANALYSIS READ ERROR'
3999               CALL ABORT
4000             ELSEIF(IRET.EQ.-1) THEN
4001               if (me .eq. 0) then
4002               PRINT *,'OLD ICE-MASK ANALYSIS PROVIDED, Indicating proper',
4003          &            ' file name is given.  No error suspected.'
4004               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4005               endif
4006             ELSE
4007               if (me .eq. 0) PRINT *,'ICE MASK ANALYSIS PROVIDED.'
4008             ENDIF
4009           ELSE
4010             if (me .eq. 0) then
4011     !       PRINT *,'************************************************'
4012             PRINT *,'NO SEA-ICE ANALYSIS AVAILABLE.  CLIMATOLOGY USED'
4013             endif
4014           ENDIF
4015     !
4016     !  Surface Roughness
4017     !
4018           IRTZOR=0
4019           IF(FNZORA(1:8).NE.'        ') THEN
4020             CALL FIXRDA(LUGB,FNZORA,KPDZOR,SLMASK,
4021          &             IY,IM,ID,IH,FH,ZORANL,LEN,IRET
4022          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4023          &,            OUTLAT, OUTLON, me)
4024             IRTZOR=IRET
4025             IF(IRET.EQ.1) THEN
4026               WRITE(6,*) 'ROUGHNESS ANALYSIS READ ERROR'
4027               CALL ABORT
4028             ELSEIF(IRET.EQ.-1) THEN
4029               if (me .eq. 0) then
4030               PRINT *,'OLD ROUGHNESS ANALYSIS PROVIDED, Indicating proper',
4031          &            ' file name is given.  No error suspected.'
4032               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4033               endif
4034             ELSE
4035               if (me .eq. 0) PRINT *,'ROUGHNESS ANALYSIS PROVIDED.'
4036             ENDIF
4037           ELSE
4038               if (me .eq. 0) then
4039     !       PRINT *,'************************************************'
4040             PRINT *,'NO SRFC ROUGHNESS ANALYSIS AVAILABLE. CLIMATOLOGY USED'
4041             endif
4042           ENDIF
4043     !
4044     !  Deep Soil Temperature
4045     !
4046           IRTTG3=0
4047           IRTSTC=0
4048           IF(FNTG3A(1:8).NE.'        ') THEN
4049             CALL FIXRDA(LUGB,FNTG3A,KPDTG3,SLMASK,
4050          &             IY,IM,ID,IH,FH,TG3ANL,LEN,IRET
4051          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4052          &,            OUTLAT, OUTLON, me)
4053             IRTTG3=IRET
4054             IF(IRET.EQ.1) THEN
4055               WRITE(6,*) 'DEEP SOIL TMP ANALYSIS READ ERROR'
4056               CALL ABORT
4057             ELSEIF(IRET.EQ.-1) THEN
4058               if (me .eq. 0) then
4059               PRINT *,'OLD DEEP SOIL TEMP ANALYSIS PROVIDED',
4060          &            ' Indicating proper file name is given.'
4061               PRINT *,' No error suspected.'
4062               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4063               endif
4064             ELSE
4065               if (me .eq. 0) PRINT *,'DEEP SOIL TMP ANALYSIS PROVIDED.'
4066             ENDIF
4067           ELSEIF(FNSTCA(1:8).NE.'        ') THEN
4068             CALL FIXRDA(LUGB,FNSTCA,KPDSTC,SLMASK,
4069          &             IY,IM,ID,IH,FH,STCANL(1,1),LEN,IRET
4070          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4071          &,            OUTLAT, OUTLON, me)
4072             CALL FIXRDA(LUGB,FNSTCA,KPDSTC,SLMASK,
4073          &             IY,IM,ID,IH,FH,STCANL(1,2),LEN,IRET
4074          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4075          &,            OUTLAT, OUTLON, me)
4076             IRTSTC=IRET
4077             IF(IRET.EQ.1) THEN
4078               WRITE(6,*) 'LAYER SOIL TMP ANALYSIS READ ERROR'
4079               CALL ABORT
4080             ELSEIF(IRET.EQ.-1) THEN
4081               if (me .eq. 0) then
4082               PRINT *,'OLD DEEP SOIL TEMP ANALYSIS PROVIDED',
4083          &            'iIndicating proper file name is given.'
4084               PRINT *,' No error suspected.'
4085               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4086               endif
4087             ELSE
4088               if (me .eq. 0) PRINT *,'LAYER SOIL TMP ANALYSIS PROVIDED.'
4089             ENDIF
4090           ELSE
4091             if (me .eq. 0) then
4092     !       PRINT *,'************************************************'
4093             PRINT *,'NO DEEP SOIL TEMP ANALY AVAILABLE.  CLIMATOLOGY USED'
4094             endif
4095           ENDIF
4096     !
4097     !  VEGETATION COVER
4098     !
4099           IRTVEG=0
4100           IF(FNVEGA(1:8).NE.'        ') THEN
4101             CALL FIXRDA(LUGB,FNVEGA,KPDVEG,SLMASK,
4102          &             IY,IM,ID,IH,FH,VEGANL,LEN,IRET
4103          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4104          &,            OUTLAT, OUTLON, me)
4105             IRTVEG=IRET
4106             IF(IRET.EQ.1) THEN
4107               WRITE(6,*) 'VEGETATION COVER ANALYSIS READ ERROR'
4108               CALL ABORT
4109             ELSEIF(IRET.EQ.-1) THEN
4110               if (me .eq. 0) then
4111               PRINT *,'OLD VEGETATION COVER ANALYSIS PROVIDED',
4112          &            ' Indicating proper file name is given.'
4113               PRINT *,' No error suspected.'
4114               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4115               endif
4116             ELSE
4117               if (me .eq. 0) PRINT *,'GEGETATION COVER ANALYSIS PROVIDED.'
4118             ENDIF
4119           ELSE
4120             if (me .eq. 0) then
4121     !       PRINT *,'************************************************'
4122             PRINT *,'NO VEGETATION COVER ANLY AVAILABLE. CLIMATOLOGY USED'
4123             endif
4124           ENDIF
4125     !
4126     !  VEGETATION type
4127     !
4128           IRTVEt=0
4129           IF(FNVEtA(1:8).NE.'        ') THEN
4130             CALL FIXRDA(LUGB,FNVEtA,KPDVEt,SLMASK,
4131          &             IY,IM,ID,IH,FH,VEtANL,LEN,IRET
4132          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4133          &,            OUTLAT, OUTLON, me)
4134             IRTVEt=IRET
4135             IF(IRET.EQ.1) THEN
4136               WRITE(6,*) 'VEGETATION type ANALYSIS READ ERROR'
4137               CALL ABORT
4138             ELSEIF(IRET.EQ.-1) THEN
4139               if (me .eq. 0) then
4140               PRINT *,'OLD VEGETATION type ANALYSIS PROVIDED',
4141          &            ' Indicating proper file name is given.'
4142               PRINT *,' No error suspected.'
4143               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4144               endif
4145             ELSE
4146               if (me .eq. 0) PRINT *,'VEGETATION type ANALYSIS PROVIDED.'
4147             ENDIF
4148           ELSE
4149             if (me .eq. 0) then
4150     !       PRINT *,'************************************************'
4151             PRINT *,'NO VEGETATION type ANLY AVAILABLE. CLIMATOLOGY USED'
4152             endif
4153           ENDIF
4154     !
4155     !  soil type
4156     !
4157           IRTsot=0
4158           IF(FNsotA(1:8).NE.'        ') THEN
4159             CALL FIXRDA(LUGB,FNsotA,KPDsot,SLMASK,
4160          &             IY,IM,ID,IH,FH,sotANL,LEN,IRET
4161          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4162          &,            OUTLAT, OUTLON, me)
4163             IRTsot=IRET
4164             IF(IRET.EQ.1) THEN
4165               WRITE(6,*) 'soil type ANALYSIS READ ERROR'
4166               CALL ABORT
4167             ELSEIF(IRET.EQ.-1) THEN
4168               if (me .eq. 0) then
4169               PRINT *,'OLD soil type ANALYSIS PROVIDED',
4170          &            ' Indicating proper file name is given.'
4171               PRINT *,' No error suspected.'
4172               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4173               endif
4174             ELSE
4175               if (me .eq. 0) PRINT *,'soil type ANALYSIS PROVIDED.'
4176             ENDIF
4177           ELSE
4178             if (me .eq. 0) then
4179     !       PRINT *,'************************************************'
4180             PRINT *,'NO soil type ANLY AVAILABLE. CLIMATOLOGY USED'
4181             endif
4182           ENDIF
4183     
4184     !Clu [+120L]--------------------------------------------------------------
4185     !
4186     !  Min vegetation cover
4187     !
4188           IRTvmn=0
4189           IF(FNvmnA(1:8).NE.'        ') THEN
4190             CALL FIXRDA(LUGB,FNvmnA,KPDvmn,SLMASK,
4191          &             IY,IM,ID,IH,FH,vmnANL,LEN,IRET
4192          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4193          &,            OUTLAT, OUTLON, me)
4194             IRTvmn=IRET
4195             IF(IRET.EQ.1) THEN
4196               WRITE(6,*) 'shdmin ANALYSIS READ ERROR'
4197               CALL ABORT
4198             ELSEIF(IRET.EQ.-1) THEN
4199               if (me .eq. 0) then
4200               PRINT *,'OLD shdmin ANALYSIS PROVIDED',
4201          &            ' Indicating proper file name is given.'
4202               PRINT *,' No error suspected.'
4203               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4204               endif
4205             ELSE
4206               if (me .eq. 0) PRINT *,'shdmin ANALYSIS PROVIDED.'
4207             ENDIF
4208           ELSE
4209             if (me .eq. 0) then
4210     !       PRINT *,'************************************************'
4211             PRINT *,'NO shdmin ANLY AVAILABLE. CLIMATOLOGY USED'
4212             endif
4213           ENDIF
4214     
4215     !
4216     !  Max vegetation cover
4217     !
4218           IRTvmx=0
4219           IF(FNvmxA(1:8).NE.'        ') THEN
4220             CALL FIXRDA(LUGB,FNvmxA,KPDvmx,SLMASK,
4221          &             IY,IM,ID,IH,FH,vmxANL,LEN,IRET
4222          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4223          &,            OUTLAT, OUTLON, me)
4224             IRTvmx=IRET
4225             IF(IRET.EQ.1) THEN
4226               WRITE(6,*) 'shdmax ANALYSIS READ ERROR'
4227               CALL ABORT
4228             ELSEIF(IRET.EQ.-1) THEN
4229               if (me .eq. 0) then
4230               PRINT *,'OLD shdmax ANALYSIS PROVIDED',
4231          &            ' Indicating proper file name is given.'
4232               PRINT *,' No error suspected.'
4233               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4234               endif
4235             ELSE
4236               if (me .eq. 0) PRINT *,'shdmax ANALYSIS PROVIDED.'
4237             ENDIF
4238           ELSE
4239             if (me .eq. 0) then
4240     !       PRINT *,'************************************************'
4241             PRINT *,'NO shdmax ANLY AVAILABLE. CLIMATOLOGY USED'
4242             endif
4243           ENDIF
4244     
4245     !
4246     !  slope type
4247     !
4248           IRTslp=0
4249           IF(FNslpA(1:8).NE.'        ') THEN
4250             CALL FIXRDA(LUGB,FNslpA,KPDslp,SLMASK,
4251          &             IY,IM,ID,IH,FH,slpANL,LEN,IRET
4252          &,            IMSK, JMSK, SLMSKH, GAUS,BLNO, BLTO
4253          &,            OUTLAT, OUTLON, me)
4254             IRTslp=IRET
4255             IF(IRET.EQ.1) THEN
4256               WRITE(6,*) 'slope type ANALYSIS READ ERROR'
4257               CALL ABORT
4258             ELSEIF(IRET.EQ.-1) THEN
4259               if (me .eq. 0) then
4260               PRINT *,'OLD slope type ANALYSIS PROVIDED',
4261          &            ' Indicating proper file name is given.'
4262               PRINT *,' No error suspected.'
4263               WRITE(6,*) 'FORECAST GUESS WILL BE USED'
4264