CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
sfcsub.F
1
3
4
11 use machine , only : kind_io8,kind_io4
12 implicit none
13 save
14!
15! grib code for each parameter - used in subroutines sfccycle and setrmsk.
16!
18 & kpdmxi,kpdscv,kpdsmc,kpdoro,kpdmsk,kpdstc,kpdacn,kpdveg,
19 & kpdvet,kpdsot,kpdsoc,
20 & kpdvmn,kpdvmx,kpdslp,kpdabs
21 &, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4)
22 parameter(kpdtsf=11, kpdwet=86, kpdsno=65, kpdzor=83,
23! & kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224,
24 & kpdais=91, kpdtg3=11, kpdplr=224,
25 & kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144,
26 & kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87,
27!cbosu max snow albedo uses a grib id number of 159, not 255.
28 & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255,
29 & kpdvet=225, kpdsot=224,kpdsoc=255,kpdabs_1=159,
30 & kpdsnd=66 )
31!
32 integer, parameter :: kpdalb_0(4)=(/212,215,213,216/)
33 integer, parameter :: kpdalb_1(4)=(/189,190,191,192/)
34 integer, parameter :: kpdalf(2)=(/214,217/)
35!
36 real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0
37 integer, parameter :: xdata=7200, ydata=3600, mdata=xdata*ydata
41 integer :: num_threads
42!
43!
44 contains
45
46 function message(prefix,index)
47 implicit none
48 character(len=*), intent(in) :: prefix
49 integer, intent(in) :: index
50 ! Safety measure: prevent writing out of bounds, use a longer string than 8 characters
51 character(len=16) :: message
52 write(message,fmt='(a,a,i0)') trim(prefix), '-', index
53 end function message
54
55 end module sfccyc_module
56
76
77 subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc &
78 &, iy,im,id,ih,fh,rla,rlo &
79 &, slmskl,slmskw,orog,orog_uf,use_ufo,nst_anl &
80 &, sihfcs,sicfcs,sitfcs &
81 &, swdfcs,slcfcs &
82 &, vmnfcs,vmxfcs,slpfcs,absfcs &
83 &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs &
84 &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs &
85 &, vegfcs,vetfcs,sotfcs,socfcs,alffcs &
86 &, cvfcs,cvbfcs,cvtfcs,me,nthrds,nlunit &
87 &, sz_nml,input_nml_file &
88 &, min_ice &
89 &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index)
90!
91 use machine , only : kind_io8,kind_io4
93 implicit none
94 character(len=*), intent(in) :: tile_num_ch
95 integer, intent(in) :: i_index(len), j_index(len), &
96 & me, nthrds
97 logical, intent(in) :: use_ufo, nst_anl
98 real (kind=kind_io8), intent(in) :: min_ice(len)
99
100 real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, &
101 & orolmx,orolmn,oroomx,oroomn,orosmx, &
102 & orosmn,oroimx,oroimn,orojmx,orojmn, &
103 & alblmx,alblmn,albomx,albomn,albsmx, &
104 & albsmn,albimx,albimn,albjmx,albjmn, &
105 & wetlmx,wetlmn,wetomx,wetomn,wetsmx, &
106 & wetsmn,wetimx,wetimn,wetjmx,wetjmn, &
107 & snolmx,snolmn,snoomx,snoomn,snosmx, &
108 & snosmn,snoimx,snoimn,snojmx,snojmn, &
109 & zorlmx,zorlmn,zoromx,zoromn,zorsmx, &
110 & zorsmn,zorimx,zorimn,zorjmx,zorjmn, &
111 & plrlmx,plrlmn,plromx,plromn,plrsmx, &
112 & plrsmn,plrimx,plrimn,plrjmx,plrjmn, &
113 & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, &
114 & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, &
115 & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, &
116 & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, &
117 & stclmx,stclmn,stcomx,stcomn,stcsmx, &
118 & stcsmn,stcimx,stcimn,stcjmx,stcjmn, &
119 & smclmx,smclmn,smcomx,smcomn,smcsmx, &
120 & smcsmn,smcimx,smcimn,smcjmx,smcjmn, &
121 & scvlmx,scvlmn,scvomx,scvomn,scvsmx, &
122 & scvsmn,scvimx,scvimn,scvjmx,scvjmn, &
123 & veglmx,veglmn,vegomx,vegomn,vegsmx, &
124 & vegsmn,vegimx,vegimn,vegjmx,vegjmn, &
125 & vetlmx,vetlmn,vetomx,vetomn,vetsmx, &
126 & vetsmn,vetimx,vetimn,vetjmx,vetjmn, &
127 & sotlmx,sotlmn,sotomx,sotomn,sotsmx, &
128 & sotsmn,sotimx,sotimn,sotjmx,sotjmn, &
129 & soclmx,soclmn,socomx,socomn,socsmx, &
130 & socsmn,socimx,socimn,socjmx,socjmn, &
131 & alslmx,alslmn,alsomx,alsomn,alssmx, &
132 & alssmn,alsimx,alsimn,alsjmx,alsjmn, &
133 & epstsf,epsalb,epssno,epswet,epszor, &
134 & epsplr,epsoro,epssmc,epsscv,eptsfc, &
135 & epstg3,epsais,epsacn,epsveg,epsvet, &
136 & epssot,epssoc,epsalf,qctsfs,qcsnos,qctsfi, &
137 & aislim,snwmin,snwmax,cplrl,cplrs, &
138 & cvegl,czors,csnol,csnos,czorl,csots, &
139 & csotl,csocs,csocl,cvwgs,cvetl,cvets,calfs, &
140 & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, &
141 & calbl,calfl,calbs,ctsfs,grboro, &
142 & grbmsk,ctsfl,deltf,caisl,caiss, &
143 & fsalfl,fsalfs,flalfs,falbl,ftsfl, &
144 & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, &
145 & faiss,fsnol,bltmsk,falbs,cvegs,percrit, &
146 & deltsfc,critp2,critp3,blnmsk,critp1, &
147 & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, &
148 & fsocl,fsocs, &
149 & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, &
150 & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, &
151 & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 &
152 &, fsihl,fsihs,fsicl,fsics, &
153 & csihl,csihs,csicl,csics,epssih,epssic &
154 &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, &
155 & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, &
156 & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, &
157 & epsslp,epsabs &
158 &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, &
159 & sihsmn,sihimx,sihimn,sihjmx,sihjmn, &
160 & siclmx,siclmn,sicomx,sicomn,sicsmx, &
161 & sicsmn,sicimx,sicimn,sicjmx,sicjmn &
162 &, glacir_hice &
163 &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, &
164 & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, &
165 & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, &
166 & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, &
167 & slplmx,slplmn,slpomx,slpomn,slpsmx, &
168 & slpsmn,slpimx,slpimn,slpjmx,slpjmn, &
169 & abslmx,abslmn,absomx,absomn,abssmx, &
170 & abssmn,absimx,absimn,absjmx,absjmn &
171 &, sihnew
172
173 integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, &
174 & irtalb,irtsot,irtsoc,irtalf,j,irtvet,irtsmc,irtstc,irtveg,&
175 & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, &
176 & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, &
177 & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, &
178 & icsnos,irttg3,kqcm,nlunit,sz_nml,ialb &
179 &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc
180 logical gausm, deads, qcmsk, znlst, monclm, monanl, &
181 & monfcs, monmer, mondif, landice
182 character(len=*), intent(in) :: input_nml_file(sz_nml)
183!
217!
218!
219! variable naming conventions:
220!
221! oro .. orography
222! alb .. albedo
223! wet .. soil wetness as defined for bucket model
224! sno .. snow depth
225! zor .. surface roughness length
226! vet .. vegetation type
227! plr .. plant evaporation resistance
228! tsf .. surface skin temperature. sea surface temp. over ocean.
229! tg3 .. deep soil temperature (at 500cm)
230! stc .. soil temperature (lsoil layrs)
231! smc .. soil moisture (lsoil layrs)
232! scv .. snow cover (not snow depth)
233! ais .. sea ice mask (0 or 1)
234! acn .. sea ice concentration (fraction)
235! gla .. glacier (permanent snow) mask (0 or 1)
236! mxi .. maximum sea ice extent (0 or 1)
237! msk .. land ocean mask (0=ocean 1=land)
238! cnp .. canopy water content
239! cv .. convective cloud cover
240! cvb .. convective cloud base
241! cvt .. convective cloud top
242! sli .. land/sea/sea-ice mask. (1/0/2 respectively)
243! veg .. vegetation cover
244! sot .. soil type
245! soc .. soil color
246!cwu [+2l] add sih & sic
247! sih .. sea ice thickness
248! sic .. sea ice concentration
249!clu [+6l] add swd,slc,vmn,vmx,slp,abs
250! swd .. actual snow depth
251! slc .. liquid soil moisture (lsoil layers)
252! vmn .. vegetation cover minimum
253! vmx .. vegetation cover maximum
254! slp .. slope type
255! abs .. maximum snow albedo
256
257!
258! definition of land/sea mask. sllnd for land and slsea for sea.
259! definition of sea/ice mask. aicice for ice, aicsea for sea.
260! tgice=max ice temperature
261! rlapse=lapse rate for sst correction due to surface angulation
262!
263 parameter(sllnd =1.0,slsea =0.0)
264 parameter(aicice=1.0,aicsea=0.0)
265 parameter(tgice=271.2)
266 parameter(rlapse=0.65e-2)
267!
268! max/min of fields for check and replace.
269!
270! ???lmx .. max over bare land
271! ???lmn .. min over bare land
272! ???omx .. max over open ocean
273! ???omn .. min over open ocean
274! ???smx .. max over snow surface (land and sea-ice)
275! ???smn .. min over snow surface (land and sea-ice)
276! ???imx .. max over bare sea ice
277! ???imn .. min over bare sea ice
278! ???jmx .. max over snow covered sea ice
279! ???jmn .. min over snow covered sea ice
280!
281 parameter(orolmx=8000.,orolmn=-1000.,oroomx=3000.,oroomn=-1000.,
282 & orosmx=8000.,orosmn=-1000.,oroimx=3000.,oroimn=-1000.,
283 & orojmx=3000.,orojmn=-1000.)
284! parameter(alblmx=0.80,alblmn=0.06,albomx=0.06,albomn=0.06,
285! & albsmx=0.80,albsmn=0.06,albimx=0.80,albimn=0.80,
286! & albjmx=0.80,albjmn=0.80)
287!cwu [-3l/+9l] change min/max for alb; add min/max for sih & sic
288! parameter(alblmx=0.80,alblmn=0.01,albomx=0.01,albomn=0.01,
289! & albsmx=0.80,albsmn=0.01,albimx=0.01,albimn=0.01,
290! & albjmx=0.01,albjmn=0.01)
291! note: the range values for bare land and snow covered land
292! (alblmx, alblmn, albsmx, albsmn) are set below
293! based on whether the old or new radiation is selected
294 parameter(albomx=0.06,albomn=0.06,
295 & albimx=0.80,albimn=0.06,
296 & albjmx=0.80,albjmn=0.06)
297 parameter(sihlmx=0.0,sihlmn=0.0,sihomx=5.0,sihomn=0.0,
298 & sihsmx=5.0,sihsmn=0.0,sihimx=5.0,sihimn=0.10,
299 & sihjmx=5.0,sihjmn=0.10,glacir_hice=3.0)
300!cwu change sicimn & sicjmn Jan 2015
301! parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0,
302! & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.50,
303! & sicjmx=1.0,sicjmn=0.50)
304!
305! parameter(sihlmx=0.0,sihlmn=0.0,sihomx=8.0,sihomn=0.0,
306! & sihsmx=8.0,sihsmn=0.0,sihimx=8.0,sihimn=0.10,
307! & sihjmx=8.0,sihjmn=0.10,glacir_hice=3.0)
308 parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0,
309 & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicjmx=1.0)
310! & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15,
311! & sicjmx=1.0,sicjmn=0.15)
312
313 parameter(wetlmx=0.15,wetlmn=0.00,wetomx=0.15,wetomn=0.15,
314 & wetsmx=0.15,wetsmn=0.15,wetimx=0.15,wetimn=0.15,
315 & wetjmx=0.15,wetjmn=0.15)
316 parameter(snolmx=0.0,snolmn=0.0,snoomx=0.0,snoomn=0.0,
317 & snosmx=55000.,snosmn=0.001,snoimx=0.,snoimn=0.0,
318 & snojmx=10000.,snojmn=0.01)
319 parameter(zorlmx=300.,zorlmn=1.0,zoromx=1.0,zoromn=1.e-05,
320 & zorsmx=300.,zorsmn=1.0,zorimx=1.0,zorimn=1.0,
321 & zorjmx=1.0,zorjmn=1.0)
322 parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0,
323 & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0,
324 & plrjmx=1000.,plrjmn=0.0)
325!clu [-1l/+1l] relax tsfsmx
326 parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2,
327 & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0,
328 & tsfjmx=273.16,tsfjmn=173.0)
329! parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.21,
330!* & tsfsmx=273.16,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0,
331! & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0,
332 parameter(tg3lmx=310.,tg3lmn=200.0,tg3omx=310.0,tg3omn=200.0,
333 & tg3smx=310.,tg3smn=200.0,tg3imx=310.0,tg3imn=200.0,
334 & tg3jmx=310.,tg3jmn=200.0)
335 parameter(stclmx=353.,stclmn=173.0,stcomx=313.0,stcomn=200.0,
336 & stcsmx=310.,stcsmn=200.0,stcimx=310.0,stcimn=200.0,
337 & stcjmx=310.,stcjmn=200.0)
338!landice mods force a flag value of soil moisture of 1.0
339! at non-land points
340 parameter(smclmx=0.55,smclmn=0.0,smcomx=1.0,smcomn=1.0,
341 & smcsmx=0.55,smcsmn=0.0,smcimx=1.0,smcimn=1.0,
342 & smcjmx=1.0,smcjmn=1.0)
343 parameter(scvlmx=0.0,scvlmn=0.0,scvomx=0.0,scvomn=0.0,
344 & scvsmx=1.0,scvsmn=1.0,scvimx=0.0,scvimn=0.0,
345 & scvjmx=1.0,scvjmn=1.0)
346 parameter(veglmx=1.0,veglmn=0.0,vegomx=0.0,vegomn=0.0,
347 & vegsmx=1.0,vegsmn=0.0,vegimx=0.0,vegimn=0.0,
348 & vegjmx=0.0,vegjmn=0.0)
349 parameter(vmnlmx=1.0,vmnlmn=0.0,vmnomx=0.0,vmnomn=0.0,
350 & vmnsmx=1.0,vmnsmn=0.0,vmnimx=0.0,vmnimn=0.0,
351 & vmnjmx=0.0,vmnjmn=0.0)
352 parameter(vmxlmx=1.0,vmxlmn=0.0,vmxomx=0.0,vmxomn=0.0,
353 & vmxsmx=1.0,vmxsmn=0.0,vmximx=0.0,vmximn=0.0,
354 & vmxjmx=0.0,vmxjmn=0.0)
355 parameter(slplmx=9.0,slplmn=1.0,slpomx=0.0,slpomn=0.0,
356 & slpsmx=9.0,slpsmn=1.0,slpimx=0.,slpimn=0.,
357 & slpjmx=0.,slpjmn=0.)
358! note: the range values for bare land and snow covered land
359! (alblmx, alblmn, albsmx, albsmn) are set below
360! based on whether the old or new radiation is selected
361 parameter(absomx=0.0,absomn=0.0,
362 & absimx=0.0,absimn=0.0,
363 & absjmx=0.0,absjmn=0.0)
364! vegetation type
365 parameter(vetlmx=20.,vetlmn=1.0,vetomx=0.0,vetomn=0.0,
366 & vetsmx=20.,vetsmn=1.0,vetimx=0.,vetimn=0.,
367 & vetjmx=0.,vetjmn=0.)
368! soil type
369 parameter(sotlmx=16.,sotlmn=1.0,sotomx=0.0,sotomn=0.0,
370 & sotsmx=16.,sotsmn=1.0,sotimx=0.,sotimn=0.,
371 & sotjmx=0.,sotjmn=0.)
372! soil color
373 parameter(soclmx=20.,soclmn=1.0,socomx=0.0,socomn=0.0,
374 & socsmx=20.,socsmn=1.0,socimx=0.,socimn=0.,
375 & socjmx=0.,socjmn=0.)
376! fraction of vegetation for strongly and weakly zeneith angle dependent
377! albedo
378 parameter(alslmx=1.0,alslmn=0.0,alsomx=0.0,alsomn=0.0,
379 & alssmx=1.0,alssmn=0.0,alsimx=0.0,alsimn=0.0,
380 & alsjmx=0.0,alsjmn=0.0)
381!
382! criteria used for monitoring
383!
384 parameter(epstsf=0.01,epsalb=0.001,epssno=0.01,
385 & epswet=0.01,epszor=0.0000001,epsplr=1.,epsoro=0.,
386 & epssmc=0.0001,epsscv=0.,eptsfc=0.01,epstg3=0.01,
387 & epsais=0.,epsacn=0.01,epsveg=0.01,
388 & epssih=0.001,epssic=0.001,
389 & epsvmn=0.01,epsvmx=0.01,epsabs=0.001,epsslp=0.01,
390 & epsvet=.01,epssot=.01,epssoc=0.01,epsalf=.001)
391!
392! quality control of analysis snow and sea ice
393!
394! qctsfs .. surface temperature above which no snow allowed
395! qcsnos .. snow depth above which snow must exist
396! qctsfi .. sst above which sea-ice is not allowed
397!
398!clu relax qctsfs (for noah lsm)
399!* parameter(qctsfs=283.16,qcsnos=100.,qctsfi=280.16)
400!* parameter(qctsfs=288.16,qcsnos=100.,qctsfi=280.16)
401 parameter(qctsfs=293.16,qcsnos=100.,qctsfi=280.16)
402!
403!cwu [-2l]
404!* ice concentration for ice limit (55 percent)
405!
406!* parameter(aislim=0.55)
407!
408! parameters to obtain snow depth from snow cover and temperature
409!
410! parameter(snwmin=25.,snwmax=100.)
411 parameter(snwmin=5.0,snwmax=100.)
412! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0
413!
414! coefficients of blending forecast and interpolated clim
415! (or analyzed) fields over sea or land(l) (not for clouds)
416! 1.0 = use of forecast
417! 0.0 = replace with interpolated analysis
418!
419! these values are set for analysis mode.
420!
421! variables land sea
422! ---------------------------------------------------------
423! surface temperature forecast analysis
424! surface temperature forecast forecast (over sea ice)
425! albedo forecast/analysis analysis
426! sea-ice analysis analysis
427! snow forecast/analysis forecast (over sea ice)
428! roughness forecast/analysis forecast
429! plant resistance analysis analysis
430! soil wetness (layer) weighted average analysis
431! soil temperature forecast analysis
432! canopy waver content forecast forecast
433! convective cloud cover forecast forecast
434! convective cloud bottm forecast forecast
435! convective cloud top forecast forecast
436! vegetation cover analysis analysis
437! vegetation type analysis analysis
438! soil type analysis analysis
439! soil color analysis analysis
440! sea-ice thickness forecast forecast
441! sea-ice concentration analysis analysis
442! vegetation cover min analysis analysis
443! vegetation cover max analysis analysis
444! max snow albedo analysis analysis
445! slope type analysis analysis
446! liquid soil wetness analysis-weighted analysis
447! actual snow depth forecast/analysis-weighted analysis
448!
449! note: if analysis file is not given, then time interpolated climatology
450! is used. if analyiss file is given, it will be used as far as the
451! date and time matches. if they do not match, it uses forecast.
452!
453! critical percentage value for aborting bad points when lgchek=.true.
454!
455 logical lgchek
456 data lgchek/.true./
457 data critp1,critp2,critp3/80.,80.,25./
458!
459! integer kpdalb(4), kpdalf(2)
460! data kpdalb/212,215,213,216/, kpdalf/214,217/
461! save kpdalb, kpdalf
462!
463! mask orography and variance on gaussian grid
464!
465 real (kind=kind_io8) slmskl(len), slmskw(len)
466 real (kind=kind_io8) orog(len), orog_uf(len), orogd(len)
467 real (kind=kind_io8) rla(len), rlo(len)
468!
469! permanent/extremes
470!
471 character*500 fnglac,fnmxic
472 real (kind=kind_io8), allocatable :: glacir(:),amxice(:),tsfcl0(:)
473!
474! tsfcl0 is the climatological tsf at fh=0
475!
476! climatology surface fields (last character 'c' or 'clm' indicate climatology)
477!
478 character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc &
479 &, fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc &
480 &, fnvegc,fnvetc,fnsotc,fnsocc &
481 &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2
482 real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len) &
483 &, zorclm(len), albclm(len,4), aisclm(len) &
484 &, tg3clm(len), acnclm(len), cnpclm(len) &
485 &, cvclm (len), cvbclm(len), cvtclm(len) &
486 &, scvclm(len), tsfcl2(len), vegclm(len) &
487 &, vetclm(len), sotclm(len), socclm(len),alfclm(len,2), sliclm(len)&
488 &, smcclm(len,lsoil), stcclm(len,lsoil) &
489 &, sihclm(len), sicclm(len) &
490 &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len)
491!
492! analyzed surface fields (last character 'a' or 'anl' indicate analysis)
493!
494 character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa &
495 &, fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna &
496 &, fnvega,fnveta,fnsota,fnsoca &
497 &, fnvmna,fnvmxa,fnslpa,fnabsa
498!
499 real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len) &
500 &, zoranl(len), albanl(len,4), aisanl(len) &
501 &, tg3anl(len), acnanl(len), cnpanl(len) &
502 &, cvanl(len), cvbanl(len), cvtanl(len) &
503 &, scvanl(len), tsfan2(len), veganl(len) &
504 &, vetanl(len), sotanl(len), socanl(len) &
505 &, alfanl(len,2), slianl(len) &
506 &, smcanl(len,lsoil), stcanl(len,lsoil) &
507 &, sihanl(len), sicanl(len) &
508 &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len)
509!
510 real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0.
511!
512! predicted surface fields (last characters 'fcs' indicates forecast)
513!
514 real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len) &
515 &, zorfcs(len), albfcs(len,4), aisfcs(len) &
516 &, tg3fcs(len), acnfcs(len), cnpfcs(len) &
517 &, cvfcs(len), cvbfcs(len), cvtfcs(len) &
518 &, slifcs(len), vegfcs(len) &
519 &, vetfcs(len), sotfcs(len), socfcs(len), alffcs(len,2) &
520 &, smcfcs(len,lsoil), stcfcs(len,lsoil) &
521 &, sihfcs(len), sicfcs(len), sitfcs(len) &
522 &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) &
523 &, swdfcs(len), slcfcs(len,lsoil)
524!
525! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched
526! in this program).
527!
528 real (kind=kind_io8) f10m(len)
529 real (kind=kind_io8) fsmcl(25), fsmcs(25), fstcl(25), fstcs(25)
530 real (kind=kind_io8) fcsmcl(25),fcsmcs(25),fcstcl(25),fcstcs(25)
531
532!clu [+1l] add swratio (soil moisture liquid-to-total ratio)
533 real (kind=kind_io8) swratio(len,lsoil)
534!clu [+1l] add fixratio (option to adjust slc from smc)
535 logical fixratio(lsoil)
536!
537 integer icsmcl(25), icsmcs(25), icstcl(25), icstcs(25)
538!
539 real (kind=kind_io8) csmcl(25), csmcs(25)
540 real (kind=kind_io8) cstcl(25), cstcs(25)
541!
542 real (kind=kind_io8) slmskh(mdata)
543 character*500 fnmskh
544 integer kpd7, kpd9
545!
546 logical icefl1(len), icefl2(len)
547!
548 real (kind=kind_io8), allocatable, dimension(:) :: &
549 & tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, aisfcsd, &
550 & cnpfcsd, vegfcsd, vetfcsd, sotfcsd, socfcsd, sihfcsd, sicfcsd, &
551 & vmnfcsd, vmxfcsd, slpfcsd, absfcsd
552 real (kind=kind_io8), allocatable, dimension(:,:) :: &
553 & smcfcsd, stcfcsd, albfcsd
554!
555! input and output surface fields (bges) file names
556!
557!
558! sigma level 1 temperature for dead start
559!
560 real (kind=kind_io8) sig1t(len)
561!
562 character*32 label
563!
564! = 1 ==> forecast is used
565! = 0 ==> analysis (or climatology) is used
566!
567! output file ... primary surface file for radiation and forecast
568!
569! rec. 1 label
570! rec. 2 date record
571! rec. 3 tsf
572! rec. 4 soilm(lsoil)
573! rec. 5 snow
574! rec. 6 soilt(lsoil)
575! rec. 7 tg3
576! rec. 8 zor
577! rec. 9 cv
578! rec. 10 cvb
579! rec. 11 cvt
580! rec. 12 albedo (four types)
581! rec. 13 slimsk
582! rec. 14 vegetation cover
583! rec. 14 plantr -----> skip this record
584! rec. 15 f10m -----> canopy
585! rec. 16 canopy water content (cnpanl) -----> f10m
586! rec. 17 vegetation type
587! rec. 18 soil type
588! rec. 18 soil color ? add later?
589! rec. 19 zeneith angle dependent vegetation fraction (two types)
590! rec. 20 uustar
591! rec. 21 ffmm
592! rec. 22 ffhh
593!cwu add sih & sic
594! rec. 23 sih(one category only)
595! rec. 24 sic
596!clu [+8l] add prcp, flag, swd, slc, vmn, vmx, slp, abs
597! rec. 25 tprcp
598! rec. 26 srflag
599! rec. 27 swd
600! rec. 28 slc (lsoil)
601! rec. 29 vmn
602! rec. 30 vmx
603! rec. 31 slp
604! rec. 32 abs
605
606!
607! debug only
608! ldebug=.true. creates bges files for climatology and analysis
609! lqcbgs=.true. quality controls input bges file before merging (should have been
610! qced in the forecast program)
611!
612 logical :: ldebug, lqcbgs, lprnt
613!
614! debug only
615!
616 character*500 fndclm,fndanl
617!
618 logical lanom
619
620!
621 namelist/namsfc/fnglac,fnmxic,
622 & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,
623 & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,
624 & fnvegc,fnvetc,fnsotc,fnsocc,fnalbc2,
625 & fnvmnc,fnvmxc,fnslpc,fnabsc,
626 & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,
627 & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna,
628 & fnvega,fnveta,fnsota,fnsoca,
629 & fnvmna,fnvmxa,fnslpa,fnabsa,
630 & fnmskh,
631 & ldebug,lgchek,lqcbgs,critp1,critp2,critp3,
632 & fndclm,fndanl,
633 & lanom,
634 & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos,
635 & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs,
636 & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots,
637 & fsocl,fsocs,
638 & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos,
639 & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs,
640 & fcstcl,fcstcs,fsalfl,fsalfs,fcalfl,flalfs,
641 & fsihl,fsicl,fsihs,fsics,aislim,sihnew,
642 & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps,
643 & fabsl,fabss,
644 & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos,
645 & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs,
646 & icstcl,icstcs,icalfl,icalfs,
647 & gausm, deads, qcmsk, znlst,
648 & monclm, monanl, monfcs, monmer, mondif, igrdbg,
649 & blnmsk, bltmsk, landice
650!
651 data gausm/.true./, deads/.false./, blnmsk/0.0/, bltmsk/90.0/
652 &, qcmsk/.false./, znlst/.false./, igrdbg/-1/
653 &, monclm/.false./, monanl/.false./, monfcs/.false./
654 &, monmer/.false./, mondif/.false./, landice/.true./
655!
656! defaults file names
657!
658 data fnmskh/'global_slmask.t126.grb'/
659 data fnalbc/'global_albedo4.1x1.grb'/
660 data fnalbc2/'global_albedo4.1x1.grb'/
661 data fntsfc/'global_sstclim.2x2.grb'/
662 data fnsotc/'global_soiltype.1x1.grb'/
663 data fnsocc/''/
664 data fnvegc/'global_vegfrac.1x1.grb'/
665 data fnvetc/'global_vegtype.1x1.grb'/
666 data fnglac/'global_glacier.2x2.grb'/
667 data fnmxic/'global_maxice.2x2.grb'/
668 data fnsnoc/'global_snoclim.1.875.grb'/
669 data fnzorc/'global_zorclim.1x1.grb'/
670 data fnaisc/'global_iceclim.2x2.grb'/
671 data fntg3c/'global_tg3clim.2.6x1.5.grb'/
672 data fnsmcc/'global_soilmcpc.1x1.grb'/
673!clu [+4l] add fn()c for vmn, vmx, abs, slp
674 data fnvmnc/'global_shdmin.0.144x0.144.grb'/
675 data fnvmxc/'global_shdmax.0.144x0.144.grb'/
676 data fnslpc/'global_slope.1x1.grb'/
677 data fnabsc/'global_snoalb.1x1.grb'/
678!
679 data fnwetc/' '/
680 data fnplrc/' '/
681 data fnstcc/' '/
682 data fnscvc/' '/
683 data fnacnc/' '/
684!
685 data fntsfa/' '/
686 data fnweta/' '/
687 data fnsnoa/' '/
688 data fnzora/' '/
689 data fnalba/' '/
690 data fnaisa/' '/
691 data fnplra/' '/
692 data fntg3a/' '/
693 data fnsmca/' '/
694 data fnstca/' '/
695 data fnscva/' '/
696 data fnacna/' '/
697 data fnvega/' '/
698 data fnveta/' '/
699 data fnsota/' '/
700 data fnsoca/' '/
701!clu [+4l] add fn()a for vmn, vmx, abs, slp
702 data fnvmna/' '/
703 data fnvmxa/' '/
704 data fnslpa/' '/
705 data fnabsa/' '/
706!
707 data ldebug/.false./, lqcbgs/.true./
708 data fndclm/' '/
709 data fndanl/' '/
710 data lanom/.false./
711!
712! default relaxation time in hours to analysis or climatology
713 data ftsfl/99999.0/, ftsfs/0.0/
714 data falbl/0.0/, falbs/0.0/
715 data falfl/0.0/, falfs/0.0/
716 data faisl/0.0/, faiss/0.0/
717 data fsnol/0.0/, fsnos/99999.0/
718 data fzorl/0.0/, fzors/99999.0/
719 data fplrl/0.0/, fplrs/0.0/
720 data fvetl/0.0/, fvets/99999.0/
721 data fsotl/0.0/, fsots/99999.0/
722 data fsocl/0.0/, fsocs/99999.0/
723 data fvegl/0.0/, fvegs/99999.0/
724!cwu [+4l] add f()l and f()s for sih, sic and aislim, sihlim
725 data fsihl/99999.0/, fsihs/99999.0/
726! data fsicl/99999.0/, fsics/99999.0/
727 data fsicl/0.0/, fsics/0.0/
728! default ice concentration limit (50%), new ice thickness (20cm)
729!cwu change ice concentration limit (15%) Jan 2015
730! data aislim/0.50/, sihnew/0.2/
731 data aislim/0.15/, sihnew/0.2/
732!clu [+4l] add f()l and f()s for vmn, vmx, abs, slp
733 data fvmnl/0.0/, fvmns/99999.0/
734 data fvmxl/0.0/, fvmxs/99999.0/
735 data fslpl/0.0/, fslps/99999.0/
736 data fabsl/0.0/, fabss/99999.0/
737! default relaxation time in hours to climatology if analysis missing
738 data fctsfl/99999.0/, fctsfs/99999.0/
739 data fcalbl/99999.0/, fcalbs/99999.0/
740 data fcsnol/99999.0/, fcsnos/99999.0/
741 data fczorl/99999.0/, fczors/99999.0/
742 data fcplrl/99999.0/, fcplrs/99999.0/
743! default flag to apply climatological annual cycle
744 data ictsfl/0/, ictsfs/1/
745 data icalbl/1/, icalbs/1/
746 data icalfl/1/, icalfs/1/
747 data icsnol/0/, icsnos/0/
748 data iczorl/1/, iczors/0/
749 data icplrl/1/, icplrs/0/
750!
751 data ccnp/1.0/
752 data ccv/1.0/, ccvb/1.0/, ccvt/1.0/
753!
754 data ifp/0/
755!
756 save ifp,fnglac,fnmxic,
757 & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,
758 & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc,
759 & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,
760 & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega,
761 & fnvetc,fnveta,
762 & fnsotc,fnsota,
763 & fnsocc,fnsoca,
764!clu [+2l] add fn()c and fn()a for vmn, vmx, slp, abs
765 & fnvmnc,fnvmxc,fnabsc,fnslpc,
766 & fnvmna,fnvmxa,fnabsa,fnslpa,
767 & ldebug,lgchek,lqcbgs,critp1,critp2,critp3,
768 & fndclm,fndanl,
769 & lanom,
770 & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos,
771 & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs,falfl,falfs,
772 & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots,
773 & fsocl,fsocs,
774 & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos,
775 & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs,
776 & fcstcl,fcstcs,fcalfl,fcalfs,
777!cwu [+1l] add f()l and f()s for sih, sic and aislim, sihnew
778 & fsihl,fsihs,fsicl,fsics,aislim,sihnew,
779!clu [+2l] add f()l and f()s for vmn, vmx, slp, abs
780 & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps,
781 & fabsl,fabss,
782 & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos,
783 & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs,
784 & icstcl,icstcs,icalfl,icalfs,
785 & gausm, deads, qcmsk,
786 & monclm, monanl, monfcs, monmer, mondif, igrdbg,
787 & grboro, grbmsk,
788!
789 & ctsfl, ctsfs, calbl, calfl, calbs, calfs, csmcs,
790 & csnol, csnos, czorl, czors, cplrl, cplrs, cstcl,
791 & cstcs, cvegl, cvwgs, cvetl, cvets, csotl, csots,
792 & csocl, csocs,
793 & csmcl
794!cwu [+1l] add c()l and c()s for sih, sic
795 &, csihl, csihs, csicl, csics
796!clu [+2l] add c()l and c()s for vmn, vmx, slp, abs
797 &, cvmnl, cvmns, cvmxl, cvmxs, cslpl, cslps,
798 & cabsl, cabss
799 &, imsk, jmsk, slmskh, blnmsk, bltmsk
800 &, glacir, amxice, tsfcl0
801 &, caisl, caiss, cvegs
802! Set number of threads num_threads in sfccyc_module for later use
803! to the value received from the calling routine (nthrds)
804 num_threads = nthrds
805!
806 lprnt = .false.
807! do i=1,len
808! if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i)
809! *,' rlo=',rlo(i)
810! tem1 = abs(rla(i) - 60.11)
811! tem2 = abs(rlo(i) - 5.38)
812! if(tem1 < 0.10 .and. tem2 < 0.10) then
813! lprnt = .true.
814! iprnt = i
815! print *,' lprnt=',lprnt,' iprnt=',iprnt
816! print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i)
817! endif
818! enddo
819
820 if (ialb == 1) then
821 kpdabs = kpdabs_1
822 kpdalb = kpdalb_1
823 alblmx = .99
824 albsmx = .99
825 alblmn = .01
826 albsmn = .01
827 abslmx = 1.0
828 abssmx = 1.0
829 abssmn = .01
830 abslmn = .01
831 elseif (ialb ==2) then
832 kpdabs = kpdabs_1
833 kpdalb = kpdalb_1
834 alblmx = .99
835 albsmx = .99
836 alblmn = .01
837 albsmn = .01
838 abslmx = 1.0
839 abssmx = 1.0
840 abssmn = .01
841 abslmn = .01
842 else
843 kpdabs = kpdabs_0
844 kpdalb = kpdalb_0
845 alblmx = .80
846 albsmx = .80
847 alblmn = .06
848 albsmn = .06
849 abslmx = .80
850 abssmx = .80
851 abslmn = .01
852 abssmn = .01
853 endif
854 if (ifp == 0) then
855 ifp = 1
856 do k=1,lsoil
857 fsmcl(k) = 99999.
858 fsmcs(k) = 0.
859 fstcl(k) = 99999.
860 fstcs(k) = 0.
861 enddo
862#ifdef INTERNAL_FILE_NML
863 read(input_nml_file, nml=namsfc)
864#else
865! print *,' in sfcsub nlunit=',nlunit,' me=',me,' ialb=',ialb
866 rewind(nlunit)
867 read (nlunit,namsfc)
868#endif
869! write(6,namsfc)
870!
871 if (me == 0) then
872 print *,' ftsfl,falbl,faisl,fsnol,fzorl=', &
873 & ftsfl,falbl,faisl,fsnol,fzorl
874 print *,' fsmcl=',fsmcl(1:lsoil)
875 print *,' fstcl=',fstcl(1:lsoil)
876 print *,' ftsfs,falbs,faiss,fsnos,fzors=', &
877 & ftsfs,falbs,faiss,fsnos,fzors
878 print *,' fsmcs=',fsmcs(1:lsoil)
879 print *,' fstcs=',fstcs(1:lsoil)
880 print *,' aislim=',aislim,' sihnew=',sihnew
881 print *,' isot=', isot,' ivegsrc=',ivegsrc
882 print *,' fnsotc =', fnsotc
883 endif
884
885 if (ivegsrc == 2) then ! sib
887 else
889 endif
890 if (isot == 0) then
892 else
894 endif
895
896 soil_color_landice = 10 !does not matter, only one source
897!
898 deltf = deltsfc / 24.0
899!
900 ctsfl = 0. !... tsfc over land
901 if (ftsfl >= 99999.) ctsfl = 1.
902 if (ftsfl > 0. .and. ftsfl < 99999) ctsfl = exp(-deltf/ftsfl)
903!
904 ctsfs=0. !... tsfc over sea
905 if (ftsfs >= 99999.) ctsfs=1.
906 if (ftsfs > 0. .and. ftsfs < 99999) ctsfs = exp(-deltf/ftsfs)
907!
908 do k=1,lsoil
909 csmcl(k) = 0. !... soilm over land
910 if (fsmcl(k) >= 99999.) csmcl(k) = 1.
911 if (fsmcl(k) > 0. .and. fsmcl(k) < 99999)
912 & csmcl(k) = exp(-deltf/fsmcl(k))
913 csmcs(k)=0. !... soilm over sea
914 if (fsmcs(k) >= 99999.) csmcs(k) = 1.
915 if (fsmcs(k) > 0. .and. fsmcs(k) < 99999)
916 & csmcs(k) = exp(-deltf/fsmcs(k))
917 enddo
918!
919 calbl = 0. !... albedo over land
920 if (ialb == 2) falbl=99999.
921 if (falbl >= 99999.) calbl = 1.
922 if (falbl > 0. .and. falbl < 99999) calbl = exp(-deltf/falbl)
923!
924 calfl=0. !... fraction field for albedo over land
925 if (falfl >= 99999.) calfl = 1.
926 if (falfl > 0. .and. falfl < 99999) calfl = exp(-deltf/falfl)
927!
928 calbs=0. !... albedo over sea
929 if (falbs >= 99999.) calbs = 1.
930 if (falbs > 0. .and. falbs < 99999) calbs = exp(-deltf/falbs)
931!
932 calfs = 0. !... fraction field for albedo over sea
933 if (falfs >= 99999.) calfs = 1.
934 if (falfs > 0. .and. falfs < 99999) calfs = exp(-deltf/falfs)
935!
936 caisl = 0. !... sea ice over land
937 if (faisl >= 99999.) caisl = 1.
938 if (faisl > 0. .and. faisl < 99999) caisl = 1.
939!
940 caiss = 0. !... sea ice over sea
941 if (faiss >= 99999.) caiss = 1.
942 if (faiss > 0. .and. faiss < 99999) caiss = 1.
943!
944 csnol = 0. !... snow over land
945 if (fsnol >= 99999.) csnol = 1.
946 if (fsnol > 0. .and. fsnol < 99999) csnol = exp(-deltf/fsnol)
947! using the same way to bending snow as narr when fsnol is the negative value
948! the magnitude of fsnol is the thread to determine the lower and upper bound
949! of final swe
950 if (fsnol < 0.) csnol = fsnol
951!
952 csnos = 0. !... snow over sea
953 if (fsnos >= 99999.) csnos = 1.
954 if (fsnos > 0 .and. fsnos < 99999) csnos = exp(-deltf/fsnos)
955!
956 czorl = 0. !... roughness length over land
957 if (fzorl >= 99999.) czorl = 1.
958 if (fzorl > 0. .and. fzorl < 99999) czorl = exp(-deltf/fzorl)
959!
960 czors = 0. !... roughness length over sea
961 if (fzors >= 99999.) czors = 1.
962 if (fzors > 0. .and. fzors < 99999) czors = exp(-deltf/fzors)
963!
964! cplrl = 0. !... plant resistance over land
965! if (fplrl >= 99999.) cplrl = 1.
966! if (fplrl > 0. .and. fplrl < 99999) cplrl=exp(-deltf/fplrl)
967!
968! cplrs = 0. !... plant resistance over sea
969! if (fplrs >= 99999.) cplrs = 1.
970! if (fplrs > 0. .and. fplrs < 99999) cplrs=exp(-deltf/fplrs)
971!
972 do k=1,lsoil
973 cstcl(k) = 0. !... soilt over land
974 if (fstcl(k) >= 99999.) cstcl(k) = 1.
975 if (fstcl(k) > 0. .and. fstcl(k) < 99999) &
976 & cstcl(k) = exp(-deltf/fstcl(k))
977 cstcs(k) = 0. !... soilt over sea
978 if (fstcs(k) >= 99999.) cstcs(k) = 1.
979 if (fstcs(k) > 0. .and. fstcs(k) < 99999) &
980 & cstcs(k) = exp(-deltf/fstcs(k))
981 enddo
982!
983 cvegl = 0. !... vegetation fraction over land
984 if (fvegl >= 99999.) cvegl = 1.
985 if (fvegl > 0. .and. fvegl < 99999) cvegl = exp(-deltf/fvegl)
986!
987 cvegs = 0. !... vegetation fraction over sea
988 if (fvegs >= 99999.) cvegs = 1.
989 if (fvegs > 0. .and. fvegs < 99999) cvegs = exp(-deltf/fvegs)
990!
991 cvetl = 0. !... vegetation type over land
992 if (fvetl >= 99999.) cvetl = 1.
993 if (fvetl > 0. .and. fvetl < 99999) cvetl = exp(-deltf/fvetl)
994!
995 cvets = 0. !... vegetation type over sea
996 if (fvets >= 99999.) cvets = 1.
997 if (fvets > 0. .and. fvets < 99999) cvets = exp(-deltf/fvets)
998!
999 csotl = 0. !... soil type over land
1000 if (fsotl >= 99999.) csotl = 1.
1001 if (fsotl > 0. .and. fsotl < 99999) csotl = exp(-deltf/fsotl)
1002!
1003 csots = 0. !... soil type over sea
1004 if (fsots >= 99999.) csots = 1.
1005 if (fsots > 0. .and. fsots < 99999) csots = exp(-deltf/fsots)
1006!
1007 csocl = 0. !... soil color over land
1008 if (fsocl >= 99999.) csocl = 1.
1009 if (fsocl > 0. .and. fsocl < 99999) csocl = exp(-deltf/fsocl)
1010!
1011 csocs = 0. !... soil color over sea
1012 if (fsocs >= 99999.) csots = 1.
1013 if (fsocs > 0. .and. fsocs < 99999) csocs = exp(-deltf/fsocs)
1014
1015
1016!cwu [+16l]---------------------------------------------------------------
1017!
1018 csihl = 0. !... sea ice thickness over land
1019 if (fsihl >= 99999.) csihl = 1.
1020 if (fsihl > 0. .and. fsihl < 99999) csihl = exp(-deltf/fsihl)
1021!
1022 csihs = 0. !... sea ice thickness over sea
1023 if (fsihs >= 99999.) csihs = 1.
1024 if (fsihs > 0. .and. fsihs < 99999) csihs = exp(-deltf/fsihs)
1025!
1026 csicl = 0. !... sea ice concentration over land
1027 if (fsicl >= 99999.) csicl = 1.
1028 if (fsicl > 0. .and. fsicl < 99999) csicl = exp(-deltf/fsicl)
1029!
1030 csics = 0. !... sea ice concentration over sea
1031 if (fsics >= 99999.) csics = 1.
1032 if (fsics > 0. .and. fsics < 99999) csics = exp(-deltf/fsics)
1033
1034!clu [+32l]---------------------------------------------------------------
1035!
1036 cvmnl = 0. !... min veg cover over land
1037 if (fvmnl >= 99999.) cvmnl = 1.
1038 if (fvmnl > 0. .and. fvmnl < 99999) cvmnl = exp(-deltf/fvmnl)
1039!
1040 cvmns = 0. !... min veg cover over sea
1041 if (fvmns >= 99999.) cvmns = 1.
1042 if (fvmns > 0. .and. fvmns < 99999) cvmns = exp(-deltf/fvmns)
1043!
1044 cvmxl = 0. !... max veg cover over land
1045 if (fvmxl >= 99999.) cvmxl = 1.
1046 if (fvmxl > 0. .and. fvmxl < 99999) cvmxl = exp(-deltf/fvmxl)
1047!
1048 cvmxs = 0. !... max veg cover over sea
1049 if (fvmxs >= 99999.) cvmxs = 1.
1050 if (fvmxs > 0. .and. fvmxs < 99999) cvmxs = exp(-deltf/fvmxs)
1051!
1052 cslpl = 0. !... slope type over land
1053 if (fslpl >= 99999.) cslpl = 1.
1054 if (fslpl > 0. .and. fslpl < 99999) cslpl = exp(-deltf/fslpl)
1055!
1056 cslps = 0. !... slope type over sea
1057 if (fslps >= 99999.) cslps = 1.
1058 if (fslps > 0. .and. fslps < 99999) cslps = exp(-deltf/fslps)
1059!
1060 cabsl = 0. !... snow albedo over land
1061 if (fabsl >= 99999.) cabsl = 1.
1062 if (fabsl > 0. .and. fabsl < 99999) cabsl = exp(-deltf/fabsl)
1063!
1064 cabss = 0. !... snow albedo over sea
1065 if (fabss >= 99999.) cabss = 1.
1066 if (fabss > 0. .and. fabss < 99999) cabss = exp(-deltf/fabss)
1067!clu ----------------------------------------------------------------------
1068!
1070!
1071 call hmskrd(lugb,imsk,jmsk,fnmskh, &
1072 & kpdmsk,slmskh,gausm,blnmsk,bltmsk,me)
1073! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo)
1074!
1075 if (me == 0) then
1076 write(6,*) ' '
1077 write(6,*) ' lugb=',lugb,' len=',len, ' lsoil=',lsoil
1078 write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh &
1079 &, ' sig1t(1)=',sig1t(1) &
1080 &, ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk
1081 write(6,*) ' '
1082 endif
1083!
1084! reading permanent/extreme features (glacier points and maximum ice extent)
1085!
1086 allocate (tsfcl0(len))
1087 allocate (glacir(len))
1088 allocate (amxice(len))
1089!
1090! read glacier
1091!
1092 kpd9 = -1
1093 kpd7 = -1
1094 call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmskl
1095 &, glacir,len,iret
1096 &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk
1097 &, rla, rlo, me)
1098! znnt=1.
1099! call nntprt(glacir,len,znnt)
1100!
1101! read maximum ice extent
1102!
1103 kpd7 = -1
1104 call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmskl
1105 &, amxice,len,iret
1106 &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk
1107 &, rla, rlo, me)
1108! znnt=1.
1109! call nntprt(amxice,len,znnt)
1110!
1111 crit=0.5
1112 call rof01(glacir,len,'ge',crit)
1113 call rof01(amxice,len,'ge',crit)
1114!
1115! quality control max ice limit based on glacier points
1116!
1117 call qcmxice(glacir,amxice,len,me)
1118!
1119 endif ! first time loop finished
1120!
1121 do i=1,len
1122 sliclm(i) = 1.
1123 snoclm(i) = 0.
1124 icefl1(i) = .true.
1125 enddo
1126!
1127! read climatology fields
1128!
1129 if (me .eq. 0) then
1130 write(6,*) '=============='
1131 write(6,*) 'climatology'
1132 write(6,*) '=============='
1133 endif
1134!
1135 percrit=critp1
1136!
1137 call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw,
1138 & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,
1139 & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc,
1140 & fnvetc,fnsotc,fnsocc,
1141 & fnvmnc,fnvmxc,fnslpc,fnabsc,
1142 & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm,
1143 & tg3clm,cvclm ,cvbclm,cvtclm,
1144 & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm,
1145 & vetclm,sotclm,socclm,alfclm,
1146 & vmnclm,vmxclm,slpclm,absclm,
1147 & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais,
1148 & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg,
1149 & kpdvet,kpdsot,kpdsoc,kpdalf,tsfcl0,
1150 & kpdvmn,kpdvmx,kpdslp,kpdabs,
1151 & deltsfc, lanom
1152 &, imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me
1153 &, lprnt,iprnt,fnalbc2,ialb,tile_num_ch,i_index,j_index)
1154
1155!
1156! scale surface roughness and albedo to model required units
1157!
1158
1159 zsca=100.
1160 call scale(zorclm,len,zsca)
1161 zsca=0.01
1162 call scale(albclm,len,zsca)
1163 call scale(albclm(1,2),len,zsca)
1164 call scale(albclm(1,3),len,zsca)
1165 call scale(albclm(1,4),len,zsca)
1166 call scale(alfclm,len,zsca)
1167 call scale(alfclm(1,2),len,zsca)
1168!clu [+4l] scale vmn, vmx, abs from percent to fraction
1169 zsca=0.01
1170 call scale(vmnclm,len,zsca)
1171 call scale(vmxclm,len,zsca)
1172 call scale(absclm,len,zsca)
1173
1174!
1175! set albedo over ocean to albomx
1176!
1177 call albocn(albclm,slmskl,albomx,len)
1178!
1179! make sure vegetation type and soil type are non zero over land
1180!
1181 call landtyp(vetclm,sotclm,socclm,slpclm,slmskl,len)
1182!
1183!cwu [-1l/+1l]
1184!* ice concentration or ice mask (only ice mask used in the model now)
1185! ice concentration and ice mask (both are used in the model now)
1186!
1187 if(fnaisc(1:8) /= ' ') then
1188!cwu [+5l/-1l] update sihclm, sicclm
1189 do i=1,len
1190 sihclm(i) = 3.0*aisclm(i)
1191 sicclm(i) = aisclm(i)
1192 if(nint(slmskl(i)) == 0 .and. nint(glacir(i)) == 1 &
1193 & .and. sicclm(i) /= 1.0) then
1194 sicclm(i) = sicimx
1195 sihfcs(i) = glacir_hice
1196 endif
1197 enddo
1198 crit=aislim
1199!* crit=0.5
1200! call rof01(aisclm,len,'ge',crit)
1201 call rof01_len(aisclm, len, 'ge', min_ice)
1202
1203 elseif(fnacnc(1:8) /= ' ') then
1204!cwu [+4l] update sihclm, sicclm
1205 do i=1,len
1206 sihclm(i) = 3.0*acnclm(i)
1207 sicclm(i) = acnclm(i)
1208 if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 &
1209 & .and. sicclm(i).ne.1.) then
1210 sicclm(i) = sicimx
1211 sihfcs(i) = glacir_hice
1212 endif
1213 enddo
1214! call rof01(acnclm,len,'ge',aislim)
1215 call rof01_len(acnclm, len, 'ge', min_ice)
1216 do i=1,len
1217 aisclm(i) = acnclm(i)
1218 enddo
1219 endif
1220!
1221! quality control of sea ice mask
1222!
1223 call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmskw,
1224 & rla,rlo,len,me)
1225!
1226! set ocean/land/sea-ice mask
1227!
1228 call setlsi(slmskl,aisclm,len,aicice,sliclm)
1229
1230! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm='
1231! &,sliclm(iprnt),' slmskw=',slmskw(iprnt)
1232!
1233! znnt=1.
1234! call nntprt(sliclm,len,znnt)
1235!
1236! quality control of snow
1237!
1238 call qcsnow(snoclm,slmskl,aisclm,glacir,len,snosmx,landice,me)
1239!
1240 call setzro(snoclm,epssno,len)
1241!
1242! snow cover handling (we assume climatological snow depth is available)
1243! quality control of snow depth (note that snow should be corrected first
1244! because it influences tsf
1245!
1246 kqcm = 1
1247 call qcmxmn('snow ',snoclm,sliclm,snoclm,icefl1,
1248 & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn,
1249 & snojmx,snojmn,snosmx,snosmn,epssno,
1250 & rla,rlo,len,kqcm,percrit,lgchek,me)
1251! write(6,*) 'snoclm'
1252! znnt=1.
1253! call nntprt(snoclm,len,znnt)
1254!
1255! get snow cover from snow depth array
1256!
1257 if(fnscvc(1:8).eq.' ') then
1258 call getscv(snoclm,scvclm,len)
1259 endif
1260!
1261! set tsfc over snow to tsfsmx if greater
1262!
1263 call snosfc(snoclm,tsfclm,tsfsmx,len,me)
1264! call snosfc(snoclm,tsfcl2,tsfsmx,len)
1265
1266!
1267! quality control
1268!
1269 do i=1,len
1270 icefl2(i) = sicclm(i) > 0.99999
1271 enddo
1272 kqcm=1
1273 call qcmxmn('tsfc ',tsfclm,sliclm,snoclm,icefl2,
1274 & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn,
1275 & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf,
1276 & rla,rlo,len,kqcm,percrit,lgchek,me)
1277 call qcmxmn('tsf2 ',tsfcl2,sliclm,snoclm,icefl2,
1278 & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn,
1279 & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf,
1280 & rla,rlo,len,kqcm,percrit,lgchek,me)
1281 do kk = 1, 4
1282 call qcmxmn('albc ',albclm(1,kk),sliclm,snoclm,icefl1,
1283 & alblmx,alblmn,albomx,albomn,albimx,albimn,
1284 & albjmx,albjmn,albsmx,albsmn,epsalb,
1285 & rla,rlo,len,kqcm,percrit,lgchek,me)
1286 enddo
1287 if(fnwetc(1:8).ne.' ') then
1288 call qcmxmn('wetc ',wetclm,sliclm,snoclm,icefl1,
1289 & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn,
1290 & wetjmx,wetjmn,wetsmx,wetsmn,epswet,
1291 & rla,rlo,len,kqcm,percrit,lgchek,me)
1292 endif
1293 call qcmxmn('zorc ',zorclm,sliclm,snoclm,icefl1,
1294 & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn,
1295 & zorjmx,zorjmn,zorsmx,zorsmn,epszor,
1296 & rla,rlo,len,kqcm,percrit,lgchek,me)
1297! if(fnplrc(1:8).ne.' ') then
1298! call qcmxmn('plntc ',plrclm,sliclm,snoclm,icefl1,
1299! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn,
1300! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr,
1301! & rla,rlo,len,kqcm,percrit,lgchek,me)
1302! endif
1303 call qcmxmn('tg3c ',tg3clm,sliclm,snoclm,icefl1,
1304 & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn,
1305 & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3,
1306 & rla,rlo,len,kqcm,percrit,lgchek,me)
1307!
1308! get soil temp and moisture (after all the qcs are completed)
1309!
1310 !-- soil moisture
1311 if(fnsmcc(1:8).eq.' ') then
1312 call getsmc(wetclm,len,lsoil,smcclm,me)
1313 endif
1314 do k=1,lsoil
1315! call qcmxmn(message('stc',k),smcclm(1,k),sliclm,snoclm,icefl1,
1316 call qcmxmn(message('stc',k),smcclm(1,k),slmskl,snoclm,icefl1,
1317 & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn,
1318 & smcjmx,smcjmn,smcsmx,smcsmn,epssmc,
1319 & rla,rlo,len,kqcm,percrit,lgchek,me)
1320 enddo
1321 !-- soil temperature
1322 if(fnstcc(1:8).eq.' ') then
1323 call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx)
1324 endif
1325 do k=1,lsoil
1326! call qcmxmn(message('stc',k),stcclm(1,k),sliclm,snoclm,icefl1,
1327 call qcmxmn(message('stc',k),stcclm(1,k),slmskl,snoclm,icefl1,
1328 & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn,
1329 & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc,
1330 & rla,rlo,len,kqcm,percrit,lgchek,me)
1331 enddo
1332! call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1,
1333 call qcmxmn('vegc ',vegclm,slmskl,snoclm,icefl1,
1334 & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn,
1335 & vegjmx,vegjmn,vegsmx,vegsmn,epsveg,
1336 & rla,rlo,len,kqcm,percrit,lgchek,me)
1337! call qcmxmn('vetc ',vetclm,sliclm,snoclm,icefl1,
1338 call qcmxmn('vetc ',vetclm,slmskl,snoclm,icefl1,
1339 & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn,
1340 & vetjmx,vetjmn,vetsmx,vetsmn,epsvet,
1341 & rla,rlo,len,kqcm,percrit,lgchek,me)
1342! call qcmxmn('sotc ',sotclm,sliclm,snoclm,icefl1,
1343 call qcmxmn('sotc ',sotclm,slmskl,snoclm,icefl1,
1344 & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn,
1345 & sotjmx,sotjmn,sotsmx,sotsmn,epssot,
1346 & rla,rlo,len,kqcm,percrit,lgchek,me)
1347! soil color
1348 call qcmxmn('socc ',socclm,slmskl,snoclm,icefl1,
1349 & soclmx,soclmn,socomx,socomn,socimx,socimn,
1350 & socjmx,socjmn,socsmx,socsmn,epssoc,
1351 & rla,rlo,len,kqcm,percrit,lgchek,me)
1352
1353! znnt=1.
1354! call nntprt(socclm,len,znnt)
1355
1356!cwu [+8l] ---------------------------------------------------------------
1357 call qcmxmn('sihc ',sihclm,sliclm,snoclm,icefl1,
1358 & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn,
1359 & sihjmx,sihjmn,sihsmx,sihsmn,epssih,
1360 & rla,rlo,len,kqcm,percrit,lgchek,me)
1361! call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1,
1362! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn,
1363! & sicjmx,sicjmn,sicsmx,sicsmn,epssic,
1364! & rla,rlo,len,kqcm,percrit,lgchek,me)
1365!clu [+16l] ---------------------------------------------------------------
1366! call qcmxmn('vmnc ',vmnclm,sliclm,snoclm,icefl1,
1367 call qcmxmn('vmnc ',vmnclm,slmskl,snoclm,icefl1,
1368 & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn,
1369 & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn,
1370 & rla,rlo,len,kqcm,percrit,lgchek,me)
1371! call qcmxmn('vmxc ',vmxclm,sliclm,snoclm,icefl1,
1372 call qcmxmn('vmxc ',vmxclm,slmskl,snoclm,icefl1,
1373 & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn,
1374 & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx,
1375 & rla,rlo,len,kqcm,percrit,lgchek,me)
1376! call qcmxmn('slpc ',slpclm,sliclm,snoclm,icefl1,
1377 call qcmxmn('slpc ',slpclm,slmskl,snoclm,icefl1,
1378 & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn,
1379 & slpjmx,slpjmn,slpsmx,slpsmn,epsslp,
1380 & rla,rlo,len,kqcm,percrit,lgchek,me)
1381 call qcmxmn('absc ',absclm,sliclm,snoclm,icefl1,
1382 & abslmx,abslmn,absomx,absomn,absimx,absimn,
1383 & absjmx,absjmn,abssmx,abssmn,epsabs,
1384 & rla,rlo,len,kqcm,percrit,lgchek,me)
1385!clu ----------------------------------------------------------------------
1386!
1387! monitoring prints
1388!
1389 if (monclm) then
1390 if (me == 0) then
1391 print *,' '
1392 print *,'monitor of time and space interpolated climatology'
1393 print *,' '
1394! call count(sliclm,snoclm,len)
1395 print *,' '
1396 call monitr('tsfclm',tsfclm,sliclm,snoclm,len)
1397 call monitr('albclm',albclm(1,1),sliclm,snoclm,len)
1398 call monitr('albclm',albclm(1,2),sliclm,snoclm,len)
1399 call monitr('albclm',albclm(1,3),sliclm,snoclm,len)
1400 call monitr('albclm',albclm(1,4),sliclm,snoclm,len)
1401 call monitr('aisclm',aisclm,sliclm,snoclm,len)
1402 call monitr('snoclm',snoclm,sliclm,snoclm,len)
1403 call monitr('scvclm',scvclm,sliclm,snoclm,len)
1404 do k=1,lsoil
1405 call monitr(message('smcclm',k),smcclm(1,k),sliclm,snoclm,len)
1406 call monitr(message('stcclm',k),stcclm(1,k),sliclm,snoclm,len)
1407 enddo
1408 call monitr('tg3clm',tg3clm,sliclm,snoclm,len)
1409 call monitr('zorclm',zorclm,sliclm,snoclm,len)
1410! if (gaus) then
1411 call monitr('cvaclm',cvclm ,sliclm,snoclm,len)
1412 call monitr('cvbclm',cvbclm,sliclm,snoclm,len)
1413 call monitr('cvtclm',cvtclm,sliclm,snoclm,len)
1414! endif
1415 call monitr('sliclm',sliclm,sliclm,snoclm,len)
1416! call monitr('plrclm',plrclm,sliclm,snoclm,len)
1417 call monitr('orog ',orog ,sliclm,snoclm,len)
1418 call monitr('vegclm',vegclm,sliclm,snoclm,len)
1419 call monitr('vetclm',vetclm,sliclm,snoclm,len)
1420 call monitr('sotclm',sotclm,sliclm,snoclm,len)
1421 call monitr('socclm',socclm,sliclm,snoclm,len)
1422!cwu [+2l] add sih, sic
1423 call monitr('sihclm',sihclm,sliclm,snoclm,len)
1424 call monitr('sicclm',sicclm,sliclm,snoclm,len)
1425!clu [+4l] add vmn, vmx, slp, abs
1426 call monitr('vmnclm',vmnclm,sliclm,snoclm,len)
1427 call monitr('vmxclm',vmxclm,sliclm,snoclm,len)
1428 call monitr('slpclm',slpclm,sliclm,snoclm,len)
1429 call monitr('absclm',absclm,sliclm,snoclm,len)
1430 endif
1431 endif
1432!
1433!
1434 if (me == 0) then
1435 write(6,*) '=============='
1436 write(6,*) ' analysis'
1437 write(6,*) '=============='
1438 endif
1439!
1440! fill in analysis array with climatology before reading analysis.
1441!
1442 call filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl,
1443 & tg3anl,cvanl ,cvbanl,cvtanl,
1444 & cnpanl,smcanl,stcanl,slianl,scvanl,veganl,
1445 & vetanl,sotanl,socanl,alfanl,
1446 & sihanl,sicanl,
1447 & vmnanl,vmxanl,slpanl,absanl,
1448 & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm,
1449 & tg3clm,cvclm ,cvbclm,cvtclm,
1450 & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm,
1451 & vetclm,sotclm,socclm,alfclm,
1452 & sihclm,sicclm,
1453 & vmnclm,vmxclm,slpclm,absclm,
1454 & len,lsoil)
1455
1456!
1457! reverse scaling to match with grib analysis input
1458!
1459 zsca = 0.01
1460 call scale(zoranl,len, zsca)
1461 zsca = 100.
1462 call scale(albanl,len,zsca)
1463 call scale(albanl(1,2),len,zsca)
1464 call scale(albanl(1,3),len,zsca)
1465 call scale(albanl(1,4),len,zsca)
1466 call scale(alfanl,len,zsca)
1467 call scale(alfanl(1,2),len,zsca)
1468!clu [+4l] reverse scale for vmn, vmx, abs
1469 zsca = 100.
1470 call scale(vmnanl,len,zsca)
1471 call scale(vmxanl,len,zsca)
1472 call scale(absanl,len,zsca)
1473!
1474 percrit = critp2
1475!
1476! read analysis fields
1477!
1478 call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw,
1479 & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,
1480 & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega,
1481 & fnveta,fnsota,fnsoca,
1482 & fnvmna,fnvmxa,fnslpa,fnabsa,
1483 & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl,
1484 & tg3anl,cvanl ,cvbanl,cvtanl,
1485 & smcanl,stcanl,slianl,scvanl,acnanl,veganl,
1486 & vetanl,sotanl,socanl,alfanl,tsfan0,
1487 & vmnanl,vmxanl,slpanl,absanl,
1488 & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais,
1489 & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg,
1490 & kpdvet,kpdsot,kpdsoc,kpdalf,
1491 & kpdvmn,kpdvmx,kpdslp,kpdabs,
1492 & irttsf,irtwet,irtsno,irtzor,irtalb,irtais,
1493 & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg,
1494 & irtvet,irtsot,irtsoc,irtalf
1495 &, irtvmn,irtvmx,irtslp,irtabs,
1496 & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk
1497 &, me, lanom)
1498
1499
1500! if(lprnt) print *,' tsfanl=',tsfanl(iprnt)
1501!
1502! scale zor and alb to match forecast model units
1503!
1504 zsca = 100.
1505 call scale(zoranl,len, zsca)
1506 zsca = 0.01
1507 call scale(albanl,len,zsca)
1508 call scale(albanl(1,2),len,zsca)
1509 call scale(albanl(1,3),len,zsca)
1510 call scale(albanl(1,4),len,zsca)
1511 call scale(alfanl,len,zsca)
1512 call scale(alfanl(1,2),len,zsca)
1513!clu [+4] scale vmn, vmx, abs from percent to fraction
1514 zsca = 0.01
1515 call scale(vmnanl,len,zsca)
1516 call scale(vmxanl,len,zsca)
1517 call scale(absanl,len,zsca)
1518!
1519! interpolate climatology but fixing initial anomaly
1520!
1521 if(fh > 0.0 .and. fntsfa(1:8) /= ' ' .and. lanom) then
1522 call anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len)
1523 endif
1524!
1525! if the tsfanl is at sea level, then bring it to the surface using
1526! unfiltered orography (for lakes). if the analysis is at lake surface
1527! as in the nst model, then this call should be removed - moorthi 09/23/2011
1528!
1529 if (use_ufo .and. .not. nst_anl) then
1530 ztsfc = 0.0
1531 call tsfcor(tsfanl,orog_uf,slmskw,ztsfc,len,rlapse)
1532 endif
1533!
1534! ice concentration or ice mask (only ice mask used in the model now)
1535!
1536 if(fnaisa(1:8) /= ' ') then
1537!cwu [+5l/-1l] update sihanl, sicanl
1538 do i=1,len
1539 sihanl(i) = 3.0*aisanl(i)
1540 sicanl(i) = aisanl(i)
1541 if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 &
1542 & .and. sicanl(i) /= 1.) then
1543 sicanl(i) = sicimx
1544 sihfcs(i) = glacir_hice
1545 endif
1546 enddo
1547! crit=aislim
1548!* crit=0.5
1549! call rof01(aisanl,len,'ge',crit)
1550 call rof01_len(aisanl, len, 'ge', min_ice)
1551 elseif(fnacna(1:8) /= ' ') then
1552!cwu [+17l] update sihanl, sicanl
1553 do i=1,len
1554 sihanl(i) = 3.0*acnanl(i)
1555 sicanl(i) = acnanl(i)
1556 if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 &
1557 & .and. sicanl(i) /= 1.) then
1558 sicanl(i) = sicimx
1559 sihfcs(i) = glacir_hice
1560 endif
1561 enddo
1562! crit=aislim
1563 do i=1,len
1564 crit = min_ice(i)
1565 if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then
1566 slianl(i) = 2.0_kind_io8
1567! print *,'cycle - new ice form: fice=',sicanl(i)
1568 elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then
1569 slianl(i) = 0.
1570! print *,'cycle - ice free: fice=',sicanl(i)
1571 elseif (nint(slianl(i)) == 1 .and. sicanl(i) >= crit) then
1572! if (nint(slmskw(i)) == 0) then ! can happen only for fractional grid
1573! slianl(i) = 2.0_kind_io8
1574! else
1575 if (nint(slmskw(i)) /= 0) then ! can happen only for fractional grid
1576! print *,'cycle - land covered by sea-ice: fice=',sicanl(i)
1577 sicanl(i) = 0.0_kind_io8
1578 endif
1579 endif
1580 enddo
1581! znnt=10.
1582! call nntprt(acnanl,len,znnt)
1583! if(lprnt) print *,' acnanl=',acnanl(iprnt)
1584! do i=1,len
1585! if (acnanl(i) .gt. 0.3 .and. aisclm(i) .eq. 1.0
1586! & .and. aisfcs(i) .ge. 0.75) acnanl(i) = aislim
1587! enddo
1588! if(lprnt) print *,' acnanl=',acnanl(iprnt)
1589! call rof01(acnanl,len,'ge',aislim)
1590 call rof01_len(acnanl, len, 'ge', min_ice)
1591 do i=1,len
1592 aisanl(i) = acnanl(i)
1593 enddo
1594 endif
1595! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' &
1596! &,glacir(iprnt),' slmskwl=',slmskw(iprnt),slmskl(iprnt)
1597!
1598 call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmskw,
1599 & rla,rlo,len,me)
1600!
1601! set ocean/land/sea-ice mask
1602!
1603 call setlsi(slmskl,aisanl,len,aicice,slianl)
1604
1605! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' &
1606! &,slianl(iprnt),' slmskwl=',slmskw(iprnt),slmskl(iprnt)
1607!
1608!
1609 do k=1,lsoil
1610 do i=1,len
1611 if (slianl(i) == 0 .and. nint(slmskl(i)) /= 1) then
1612 smcanl(i,k) = smcomx
1613 stcanl(i,k) = tsfanl(i)
1614 endif
1615 enddo
1616 enddo
1617
1618! write(6,*) 'slianl'
1619! znnt=1.
1620! call nntprt(slianl,len,znnt)
1621!cwu [+8l]----------------------------------------------------------------------
1622 call qcmxmn('siha ',sihanl,slianl,snoanl,icefl1,
1623 & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn,
1624 & sihjmx,sihjmn,sihsmx,sihsmn,epssih,
1625 & rla,rlo,len,kqcm,percrit,lgchek,me)
1626! call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1,
1627! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn,
1628! & sicjmx,sicjmn,sicsmx,sicsmn,epssic,
1629! & rla,rlo,len,kqcm,percrit,lgchek,me)
1630!
1631! set albedo over ocean to albomx
1632!
1633 call albocn(albanl,slmskl,albomx,len)
1634!
1635! quality control of snow and sea-ice
1636! process snow depth or snow cover
1637!
1638 if (fnsnoa(1:8) /= ' ') then
1639 call setzro(snoanl,epssno,len)
1640 call qcsnow(snoanl,slmskl,aisanl,glacir,len,ten,landice,me)
1641 if (.not.landice) then
1642 call snodpth2(glacir,snosmx,snoanl, len, me)
1643 endif
1644 kqcm = 1
1645 call snosfc(snoanl,tsfanl,tsfsmx,len,me)
1646 call qcmxmn('snoa ',snoanl,slianl,snoanl,icefl1,
1647 & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn,
1648 & snojmx,snojmn,snosmx,snosmn,epssno,
1649 & rla,rlo,len,kqcm,percrit,lgchek,me)
1650 call getscv(snoanl,scvanl,len)
1651 call qcmxmn('sncva ',scvanl,slianl,snoanl,icefl1,
1652 & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn,
1653 & scvjmx,scvjmn,scvsmx,scvsmn,epsscv,
1654 & rla,rlo,len,kqcm,percrit,lgchek,me)
1655 else
1656 crit = 0.5
1657 call rof01(scvanl,len,'ge',crit)
1658 call qcsnow(scvanl,slmskl,aisanl,glacir,len,one,landice,me)
1659 call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1,
1660 & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn,
1661 & scvjmx,scvjmn,scvsmx,scvsmn,epsscv,
1662 & rla,rlo,len,kqcm,percrit,lgchek,me)
1663 call snodpth(scvanl,slianl,tsfanl,snoclm,
1664 & glacir,snwmax,snwmin,landice,len,snoanl,me)
1665 call qcsnow(scvanl,slmskl,aisanl,glacir,len,snosmx,landice,me)
1666 call snosfc(snoanl,tsfanl,tsfsmx,len,me)
1667 call qcmxmn('snowa ',snoanl,slianl,snoanl,icefl1,
1668 & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn,
1669 & snojmx,snojmn,snosmx,snosmn,epssno,
1670 & rla,rlo,len,kqcm,percrit,lgchek,me)
1671 endif
1672!
1673 do i=1,len
1674 icefl2(i) = sicanl(i) > 0.99999
1675 enddo
1676 call qcmxmn('tsfa ',tsfanl,slianl,snoanl,icefl2,
1677 & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn,
1678 & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf,
1679 & rla,rlo,len,kqcm,percrit,lgchek,me)
1680 do kk = 1, 4
1681 call qcmxmn('alba ',albanl(1,kk),slianl,snoanl,icefl1,
1682 & alblmx,alblmn,albomx,albomn,albimx,albimn,
1683 & albjmx,albjmn,albsmx,albsmn,epsalb,
1684 & rla,rlo,len,kqcm,percrit,lgchek,me)
1685 enddo
1686 if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ' ) then
1687 call qcmxmn('weta ',wetanl,slianl,snoanl,icefl1,
1688 & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn,
1689 & wetjmx,wetjmn,wetsmx,wetsmn,epswet,
1690 & rla,rlo,len,kqcm,percrit,lgchek,me)
1691 endif
1692 call qcmxmn('zora ',zoranl,slianl,snoanl,icefl1,
1693 & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn,
1694 & zorjmx,zorjmn,zorsmx,zorsmn,epszor,
1695 & rla,rlo,len,kqcm,percrit,lgchek,me)
1696! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) then
1697! call qcmxmn('plna ',plranl,slianl,snoanl,icefl1,
1698! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn,
1699! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr,
1700! & rla,rlo,len,kqcm,percrit,lgchek,me)
1701! endif
1702! call qcmxmn('tg3a ',tg3anl,slianl,snoanl,icefl1,
1703 call qcmxmn('tg3a ',tg3anl,slmskl,snoanl,icefl1,
1704 & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn,
1705 & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3,
1706 & rla,rlo,len,kqcm,percrit,lgchek,me)
1707!
1708! get soil temp and moisture
1709!
1710 if(fnsmca(1:8) == ' ' .and. fnsmcc(1:8) == ' ') then
1711 call getsmc(wetanl,len,lsoil,smcanl,me)
1712 endif
1713 !-- soil moisture
1714 do k=1,lsoil
1715! call qcmxmn(message('smca',k),smcanl(1,1),slianl,snoanl,icefl1,
1716 call qcmxmn(message('smca',k),smcanl(1,1),slmskl,snoanl,icefl1,
1717 & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn,
1718 & smcjmx,smcjmn,smcsmx,smcsmn,epssmc,
1719 & rla,rlo,len,kqcm,percrit,lgchek,me)
1720 enddo
1721 !-- soil temperature
1722 if(fnstca(1:8).eq.' ') then
1723 call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx)
1724 endif
1725 do k=1,lsoil
1726! call qcmxmn(message('stca',k),stcanl(1,1),slianl,snoanl,icefl1,
1727 call qcmxmn(message('stca',k),stcanl(1,1),slmskl,snoanl,icefl1,
1728 & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn,
1729 & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc,
1730 & rla,rlo,len,kqcm,percrit,lgchek,me)
1731 enddo
1732! call qcmxmn('vega ',veganl,slianl,snoanl,icefl1,
1733 call qcmxmn('vega ',veganl,slmskl,snoanl,icefl1,
1734 & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn,
1735 & vegjmx,vegjmn,vegsmx,vegsmn,epsveg,
1736 & rla,rlo,len,kqcm,percrit,lgchek,me)
1737! call qcmxmn('veta ',vetanl,slianl,snoanl,icefl1,
1738 call qcmxmn('veta ',vetanl,slmskl,snoanl,icefl1,
1739 & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn,
1740 & vetjmx,vetjmn,vetsmx,vetsmn,epsvet,
1741 & rla,rlo,len,kqcm,percrit,lgchek,me)
1742! call qcmxmn('sota ',sotanl,slianl,snoanl,icefl1,
1743 call qcmxmn('sota ',sotanl,slmskl,snoanl,icefl1,
1744 & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn,
1745 & sotjmx,sotjmn,sotsmx,sotsmn,epssot,
1746 & rla,rlo,len,kqcm,percrit,lgchek,me)
1747! soil color
1748 call qcmxmn('soca ',socanl,slmskl,snoanl,icefl1,
1749 & soclmx,soclmn,socomx,socomn,socimx,socimn,
1750 & socjmx,socjmn,socsmx,socsmn,epssoc,
1751 & rla,rlo,len,kqcm,percrit,lgchek,me)
1752
1753!clu [+16l]----------------------------------------------------------------------
1754! call qcmxmn('vmna ',vmnanl,slianl,snoanl,icefl1,
1755 call qcmxmn('vmna ',vmnanl,slmskl,snoanl,icefl1,
1756 & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn,
1757 & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn,
1758 & rla,rlo,len,kqcm,percrit,lgchek,me)
1759! call qcmxmn('vmxa ',vmxanl,slianl,snoanl,icefl1,
1760 call qcmxmn('vmxa ',vmxanl,slmskl,snoanl,icefl1,
1761 & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn,
1762 & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx,
1763 & rla,rlo,len,kqcm,percrit,lgchek,me)
1764! call qcmxmn('slpa ',slpanl,slianl,snoanl,icefl1,
1765 call qcmxmn('slpa ',slpanl,slmskl,snoanl,icefl1,
1766 & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn,
1767 & slpjmx,slpjmn,slpsmx,slpsmn,epsslp,
1768 & rla,rlo,len,kqcm,percrit,lgchek,me)
1769 call qcmxmn('absa ',absanl,slianl,snoanl,icefl1,
1770 & abslmx,abslmn,absomx,absomn,absimx,absimn,
1771 & absjmx,absjmn,abssmx,abssmn,epsabs,
1772 & rla,rlo,len,kqcm,percrit,lgchek,me)
1773!clu ----------------------------------------------------------------------------
1774!
1775! monitoring prints
1776!
1777 if (monanl) then
1778 if (me == 0) then
1779 print *,' '
1780 print *,'monitor of time and space interpolated analysis'
1781 print *,' '
1782! call count(slianl,snoanl,len)
1783 print *,' '
1784 call monitr('tsfanl',tsfanl,slianl,snoanl,len)
1785 call monitr('albanl',albanl,slianl,snoanl,len)
1786 call monitr('aisanl',aisanl,slianl,snoanl,len)
1787 call monitr('snoanl',snoanl,slianl,snoanl,len)
1788 call monitr('scvanl',scvanl,slianl,snoanl,len)
1789 do k=1,lsoil
1790 call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len)
1791 call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len)
1792 enddo
1793 call monitr('tg3anl',tg3anl,slianl,snoanl,len)
1794 call monitr('zoranl',zoranl,slianl,snoanl,len)
1795! if (gaus) then
1796 call monitr('cvaanl',cvanl ,slianl,snoanl,len)
1797 call monitr('cvbanl',cvbanl,slianl,snoanl,len)
1798 call monitr('cvtanl',cvtanl,slianl,snoanl,len)
1799! endif
1800 call monitr('slianl',slianl,slianl,snoanl,len)
1801! call monitr('plranl',plranl,slianl,snoanl,len)
1802 call monitr('orog ',orog ,slianl,snoanl,len)
1803 call monitr('veganl',veganl,slianl,snoanl,len)
1804 call monitr('vetanl',vetanl,slianl,snoanl,len)
1805 call monitr('sotanl',sotanl,slianl,snoanl,len)
1806 call monitr('socanl',socanl,slianl,snoanl,len)
1807!cwu [+2l] add sih, sic
1808 call monitr('sihanl',sihanl,slianl,snoanl,len)
1809 call monitr('sicanl',sicanl,slianl,snoanl,len)
1810!clu [+4l] add vmn, vmx, slp, abs
1811 call monitr('vmnanl',vmnanl,slianl,snoanl,len)
1812 call monitr('vmxanl',vmxanl,slianl,snoanl,len)
1813 call monitr('slpanl',slpanl,slianl,snoanl,len)
1814 call monitr('absanl',absanl,slianl,snoanl,len)
1815 endif
1816
1817 endif
1818!
1819! read in forecast fields if needed
1820!
1821 if (me == 0) then
1822 write(6,*) '=============='
1823 write(6,*) ' fcst guess'
1824 write(6,*) '=============='
1825 endif
1826!
1827 percrit = critp2
1828!
1829 if(deads) then
1830!
1831! fill in guess array with analysis if dead start.
1832!
1833 percrit=critp3
1834 if (me == 0) write(6,*) 'this run is dead start run'
1835 call filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs,
1836 & tg3fcs,cvfcs ,cvbfcs,cvtfcs,
1837 & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs,
1838 & vegfcs,vetfcs,sotfcs,socfcs,alffcs,
1839!cwu [+1l] add ()fcs for sih, sic
1840 & sihfcs,sicfcs,
1841!clu [+1l] add ()fcs for vmn, vmx, slp, abs
1842 & vmnfcs,vmxfcs,slpfcs,absfcs,
1843 & tsfanl,wetanl,snoanl,zoranl,albanl,
1844 & tg3anl,cvanl ,cvbanl,cvtanl,
1845 & cnpanl,smcanl,stcanl,slianl,aisanl,
1846 & veganl,vetanl,sotanl,socanl,alfanl,
1847!cwu [+1l] add ()anl for sih, sic
1848 & sihanl,sicanl,
1849!clu [+1l] add ()anl for vmn, vmx, slp, abs
1850 & vmnanl,vmxanl,slpanl,absanl,
1851 & len,lsoil)
1852
1853 do i=1,len
1854 print *, 'AFTER FILFCS (i) is ',socfcs(i)
1855 enddo
1856
1857 if (sig1t(1) /= 0.) then
1858 call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs,
1859 & tsfimx)
1860 do i=1,len
1861 icefl2(i) = sicfcs(i) > 0.99999
1862 enddo
1863 kqcm = 1
1864 call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2,
1865 & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn,
1866 & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf,
1867 & rla,rlo,len,kqcm,percrit,lgchek,me)
1868! call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1,
1869 call qcmxmn('stc1f ',stcfcs(1,1),slmskl,snofcs,icefl1,
1870 & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn,
1871 & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc,
1872 & rla,rlo,len,kqcm,percrit,lgchek,me)
1873! call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1,
1874 call qcmxmn('stc2f ',stcfcs(1,2),slmskl,snofcs,icefl1,
1875 & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn,
1876 & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc,
1877 & rla,rlo,len,kqcm,percrit,lgchek,me)
1878 endif
1879 else
1880 percrit = critp2
1881!
1882! make reverse angulation correction to tsf
1883! make reverse orography correction to tg3
1884!
1885 if (use_ufo) then
1886 orogd = orog - orog_uf
1887!
1888! The tiled version of the substrate temperature is properly
1889! adjusted to the terrain. Only invoke when using the old
1890! global tg3 grib file.
1891!
1892 if ( index(fntg3c, "tileX.nc") == 0) then ! global file
1893 ztsfc = 1.0
1894 call tsfcor(tg3fcs,orogd,slmskl,ztsfc,len,-rlapse)
1895 endif
1896 ztsfc = 0.
1897 call tsfcor(tsffcs,orogd,slmskw,ztsfc,len,-rlapse)
1898 else
1899 ztsfc = 0.
1900 call tsfcor(tsffcs,orog,slmskw,ztsfc,len,-rlapse)
1901 endif
1902
1903!clu [+12l] --------------------------------------------------------------
1904!
1905! compute soil moisture liquid-to-total ratio over land
1906!
1907 do j=1, lsoil
1908 do i=1, len
1909 if(smcfcs(i,j) /= 0.) then
1910 swratio(i,j) = slcfcs(i,j)/smcfcs(i,j)
1911 else
1912 swratio(i,j) = -999.
1913 endif
1914 enddo
1915 enddo
1916!clu -----------------------------------------------------------------------
1917!
1918 if (lqcbgs .and. irtacn == 0) then
1919 call qcsli(slianl,slifcs,len,me)
1920 call albocn(albfcs,slmskl,albomx,len)
1921 do i=1,len
1922 icefl2(i) = sicfcs(i) .gt. 0.99999
1923 enddo
1924 kqcm = 1
1925 call qcmxmn('snof ',snofcs,slifcs,snofcs,icefl1,
1926 & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn,
1927 & snojmx,snojmn,snosmx,snosmn,epssno,
1928 & rla,rlo,len,kqcm,percrit,lgchek,me)
1929 call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2,
1930 & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn,
1931 & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf,
1932 & rla,rlo,len,kqcm,percrit,lgchek,me)
1933 do kk = 1, 4
1934 call qcmxmn('albf ',albfcs(1,kk),slifcs,snofcs,icefl1,
1935 & alblmx,alblmn,albomx,albomn,albimx,albimn,
1936 & albjmx,albjmn,albsmx,albsmn,epsalb,
1937 & rla,rlo,len,kqcm,percrit,lgchek,me)
1938 enddo
1939 if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ' )
1940 & then
1941 call qcmxmn('wetf ',wetfcs,slifcs,snofcs,icefl1,
1942 & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn,
1943 & wetjmx,wetjmn,wetsmx,wetsmn,epswet,
1944 & rla,rlo,len,kqcm,percrit,lgchek,me)
1945 endif
1946 call qcmxmn('zorf ',zorfcs,slifcs,snofcs,icefl1,
1947 & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn,
1948 & zorjmx,zorjmn,zorsmx,zorsmn,epszor,
1949 & rla,rlo,len,kqcm,percrit,lgchek,me)
1950! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' )
1951! call qcmxmn('plnf ',plrfcs,slifcs,snofcs,icefl1,
1952! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn,
1953! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr,
1954! & rla,rlo,len,kqcm,percrit,lgchek,me)
1955! endif
1956! call qcmxmn('tg3f ',tg3fcs,slifcs,snofcs,icefl1,
1957 call qcmxmn('tg3f ',tg3fcs,slmskl,snofcs,icefl1,
1958 & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn,
1959 & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3,
1960 & rla,rlo,len,kqcm,percrit,lgchek,me)
1961!cwu [+8l] ---------------------------------------------------------------
1962 call qcmxmn('sihf ',sihfcs,slifcs,snofcs,icefl1,
1963 & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn,
1964 & sihjmx,sihjmn,sihsmx,sihsmn,epssih,
1965 & rla,rlo,len,kqcm,percrit,lgchek,me)
1966! call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1,
1967! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn,
1968! & sicjmx,sicjmn,sicsmx,sicsmn,epssic,
1969! & rla,rlo,len,kqcm,percrit,lgchek,me)
1970!-- soil moisture forecast
1971 do k=1,lsoil
1972! call qcmxmn(message('smcfcw',k),smcfcs(1,k),slifcs,
1973 call qcmxmn(message('smcfcw',k),smcfcs(1,k),slmskl,
1974 & snofcs,icefl1,
1975 & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn,
1976 & smcjmx,smcjmn,smcsmx,smcsmn,epssmc,
1977 & rla,rlo,len,kqcm,percrit,lgchek,me)
1978 enddo
1979!-- soil temperature forecast
1980 do k=1,lsoil
1981! call qcmxmn(message('stcf',k),stcfcs(1,k),slifcs,
1982 call qcmxmn(message('stcf',k),stcfcs(1,k),slmskl,
1983 & snofcs,icefl1,
1984 & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn,
1985 & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc,
1986 & rla,rlo,len,kqcm,percrit,lgchek,me)
1987 enddo
1988! call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1,
1989 call qcmxmn('vegf ',vegfcs,slmskl,snofcs,icefl1,
1990 & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn,
1991 & vegjmx,vegjmn,vegsmx,vegsmn,epsveg,
1992 & rla,rlo,len,kqcm,percrit,lgchek,me)
1993! call qcmxmn('vetf ',vetfcs,slifcs,snofcs,icefl1,
1994 call qcmxmn('vetf ',vetfcs,slmskl,snofcs,icefl1,
1995 & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn,
1996 & vetjmx,vetjmn,vetsmx,vetsmn,epsvet,
1997 & rla,rlo,len,kqcm,percrit,lgchek,me)
1998! call qcmxmn('sotf ',sotfcs,slifcs,snofcs,icefl1,
1999 call qcmxmn('sotf ',sotfcs,slmskl,snofcs,icefl1,
2000 & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn,
2001 & sotjmx,sotjmn,sotsmx,sotsmn,epssot,
2002 & rla,rlo,len,kqcm,percrit,lgchek,me)
2003 call qcmxmn('socf ',socfcs,slmskl,snofcs,icefl1,
2004 & soclmx,soclmn,socomx,socomn,socimx,socimn,
2005 & socjmx,socjmn,socsmx,socsmn,epssoc,
2006 & rla,rlo,len,kqcm,percrit,lgchek,me)
2007
2008
2009!clu [+16l] ---------------------------------------------------------------
2010! call qcmxmn('vmnf ',vmnfcs,slifcs,snofcs,icefl1,
2011 call qcmxmn('vmnf ',vmnfcs,slmskl,snofcs,icefl1,
2012 & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn,
2013 & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn,
2014 & rla,rlo,len,kqcm,percrit,lgchek,me)
2015! call qcmxmn('vmxf ',vmxfcs,slifcs,snofcs,icefl1,
2016 call qcmxmn('vmxf ',vmxfcs,slmskl,snofcs,icefl1,
2017 & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn,
2018 & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx,
2019 & rla,rlo,len,kqcm,percrit,lgchek,me)
2020! call qcmxmn('slpf ',slpfcs,slifcs,snofcs,icefl1,
2021 call qcmxmn('slpf ',slpfcs,slmskl,snofcs,icefl1,
2022 & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn,
2023 & slpjmx,slpjmn,slpsmx,slpsmn,epsslp,
2024 & rla,rlo,len,kqcm,percrit,lgchek,me)
2025 call qcmxmn('absf ',absfcs,slifcs,snofcs,icefl1,
2026 & abslmx,abslmn,absomx,absomn,absimx,absimn,
2027 & absjmx,absjmn,abssmx,abssmn,epsabs,
2028 & rla,rlo,len,kqcm,percrit,lgchek,me)
2029!clu -----------------------------------------------------------------------
2030 endif
2031 endif
2032!
2033 if (monfcs) then
2034 if (me == 0) then
2035 print *,' '
2036 print *,'monitor of guess'
2037 print *,' '
2038! call count(slifcs,snofcs,len)
2039 print *,' '
2040 call monitr('tsffcs',tsffcs,slifcs,snofcs,len)
2041 call monitr('albfcs',albfcs,slifcs,snofcs,len)
2042 call monitr('aisfcs',aisfcs,slifcs,snofcs,len)
2043 call monitr('snofcs',snofcs,slifcs,snofcs,len)
2044 do k=1,lsoil
2045 call monitr(message('smcfcs',k),smcfcs(1,k),slifcs,snofcs,len)
2046 call monitr(message('stcfcs',k),stcfcs(1,k),slifcs,snofcs,len)
2047 enddo
2048 call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len)
2049 call monitr('zorfcs',zorfcs,slifcs,snofcs,len)
2050! if (gaus) then
2051 call monitr('cvafcs',cvfcs ,slifcs,snofcs,len)
2052 call monitr('cvbfcs',cvbfcs,slifcs,snofcs,len)
2053 call monitr('cvtfcs',cvtfcs,slifcs,snofcs,len)
2054! endif
2055 call monitr('slifcs',slifcs,slifcs,snofcs,len)
2056! call monitr('plrfcs',plrfcs,slifcs,snofcs,len)
2057 call monitr('orog ',orog ,slifcs,snofcs,len)
2058 call monitr('vegfcs',vegfcs,slifcs,snofcs,len)
2059 call monitr('vetfcs',vetfcs,slifcs,snofcs,len)
2060 call monitr('sotfcs',sotfcs,slifcs,snofcs,len)
2061 call monitr('socfcs',socfcs,slifcs,snofcs,len)
2062!cwu [+2l] add sih, sic
2063 call monitr('sihfcs',sihfcs,slifcs,snofcs,len)
2064 call monitr('sicfcs',sicfcs,slifcs,snofcs,len)
2065!clu [+4l] add vmn, vmx, slp, abs
2066 call monitr('vmnfcs',vmnfcs,slifcs,snofcs,len)
2067 call monitr('vmxfcs',vmxfcs,slifcs,snofcs,len)
2068 call monitr('slpfcs',slpfcs,slifcs,snofcs,len)
2069 call monitr('absfcs',absfcs,slifcs,snofcs,len)
2070 endif
2071 endif
2072!
2073!... update annual cycle in the sst guess..
2074!
2075! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt)
2076! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt)
2077
2078 do i=1,len
2079 if (nint(slmskl(i)) /= 1) then
2080 if (sicanl(i) >= min_ice(i)) then
2081 slianl(i) = 2.0_kind_io8
2082 else
2083 slianl(i) = zero
2084 sicanl(i) = zero
2085 endif
2086 endif
2087 enddo
2088
2089 if (fh-deltsfc > -0.001 ) then
2090 do i=1,len
2091 if(slianl(i) == 0.0) then
2092 tsffcs(i) = tsffcs(i) + (tsfclm(i) - tsfcl2(i))
2093 endif
2094 enddo
2095 endif
2096!
2097! quality control analysis using forecast guess
2098!
2099 call qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi,len,lsoil,
2100 & snoanl,aisanl,slianl,tsfanl,albanl,
2101 & zoranl,smcanl,
2102 & smcclm,tsfsmx,albomx,zoromx,me)
2103!
2104! blend climatology and predicted fields
2105!
2106 if(me == 0) then
2107 write(6,*) '=============='
2108 write(6,*) ' merging'
2109 write(6,*) '=============='
2110 endif
2111! if(lprnt) print *,' tsffcs=',tsffcs(iprnt)
2112!
2113 percrit = critp3
2114!
2115! merge analysis and forecast. note tg3, ais are not merged
2116!
2117! if(lprnt) print *,' stcfcsbefmer=',stcfcs(iprnt,:)
2118! if(lprnt) print *,' stcanlbefmer=',stcanl(iprnt,:)
2119
2120 call merge(len,lsoil,iy,im,id,ih,fh,deltsfc,
2121 & slmskl,slmskw,sihfcs,sicfcs,
2122 & vmnfcs,vmxfcs,slpfcs,absfcs,
2123 & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs,
2124 & cvfcs ,cvbfcs,cvtfcs,
2125 & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs,
2126 & vetfcs,sotfcs,socfcs,alffcs,
2127 & sihanl,sicanl,
2128 & vmnanl,vmxanl,slpanl,absanl,
2129 & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl,
2130 & cvanl ,cvbanl,cvtanl,
2131 & cnpanl,smcanl,stcanl,slianl,veganl,
2132 & vetanl,sotanl,socanl,alfanl,
2133 & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl,
2134 & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs,
2135 & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots,csocl,csocs,
2136 & calfl,calfs,
2137 & csihl,csihs,csicl,csics,
2138 & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss,
2139 & irttsf,irtwet,irtsno,irtzor,irtalb,irtais,
2140 & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg,
2141 & irtvmn,irtvmx,irtslp,irtabs,
2142 & irtvet,irtsot,irtsoc,irtalf,landice,me)
2143
2144 call setzro(snoanl,epssno,len)
2145
2146! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt)
2147! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt)
2148! if(lprnt) print *,' stcfcsmer=',stcfcs(iprnt,:)
2149! if(lprnt) print *,' stcanlmer=',stcanl(iprnt,:)
2150
2151!
2152! new ice/melted ice
2153!
2154 call newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil,
2155!cwu [+1l] add sihnew, aislim, sihanl & sicanl
2156 & sihnew,aislim,sihanl,sicanl,
2157 & albanl,snoanl,zoranl,smcanl,stcanl,
2158 & albomx,snoomx,zoromx,smcomx,smcimx,
2159!cwu [-1l/+1l] change albimx to albimn - note albimx & albimn have been modified
2160! & tsfomn,tsfimx,albimx,zorimx,tgice,
2161 & tsfomn,tsfimx,albimn,zorimx,tgice,
2162 & rla,rlo,me)
2163
2164! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt)
2165! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt)
2166! if(lprnt) print *,' stcan=',stcanl(iprnt,:)
2167
2168! set tsfc to tsnow over snow
2169!
2170 call snosfc(snoanl,tsfanl,tsfsmx,len,me)
2171!
2172 do i=1,len
2173 icefl2(i) = sicanl(i) > 0.99999
2174 enddo
2175 kqcm = 0
2176 call qcmxmn('snowm ',snoanl,slianl,snoanl,icefl1,
2177 & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn,
2178 & snojmx,snojmn,snosmx,snosmn,epssno,
2179 & rla,rlo,len,kqcm,percrit,lgchek,me)
2180 call qcmxmn('tsfm ',tsfanl,slianl,snoanl,icefl2,
2181 & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn,
2182 & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf,
2183 & rla,rlo,len,kqcm,percrit,lgchek,me)
2184 do kk = 1, 4
2185 call qcmxmn('albm ',albanl(1,kk),slianl,snoanl,icefl1,
2186 & alblmx,alblmn,albomx,albomn,albimx,albimn,
2187 & albjmx,albjmn,albsmx,albsmn,epsalb,
2188 & rla,rlo,len,kqcm,percrit,lgchek,me)
2189 enddo
2190 if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ') then
2191 call qcmxmn('wetm ',wetanl,slianl,snoanl,icefl1,
2192 & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn,
2193 & wetjmx,wetjmn,wetsmx,wetsmn,epswet,
2194 & rla,rlo,len,kqcm,percrit,lgchek,me)
2195 endif
2196 call qcmxmn('zorm ',zoranl,slianl,snoanl,icefl1,
2197 & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn,
2198 & zorjmx,zorjmn,zorsmx,zorsmn,epszor,
2199 & rla,rlo,len,kqcm,percrit,lgchek,me)
2200! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' )
2201! & then
2202! call qcmxmn('plntm ',plranl,slianl,snoanl,icefl1,
2203! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn,
2204! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr,
2205! & rla,rlo,len,kqcm,percrit,lgchek,me)
2206! endif
2207 do k=1,lsoil
2208! call qcmxmn(message('stcm',k),stcanl(1,k),slianl,snoanl,icefl1,
2209 call qcmxmn(message('stcm',k),stcanl(1,k),slmskl,snoanl,icefl1,
2210 & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn,
2211 & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc,
2212 & rla,rlo,len,kqcm,percrit,lgchek,me)
2213 enddo
2214 do k=1,lsoil
2215! call qcmxmn(message('smcm',k),smcanl(1,k),slianl,snoanl,icefl1,
2216 call qcmxmn(message('smcm',k),smcanl(1,k),slmskl,snoanl,icefl1,
2217 & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn,
2218 & smcjmx,smcjmn,smcsmx,smcsmn,epssmc,
2219 & rla,rlo,len,kqcm,percrit,lgchek,me)
2220 enddo
2221 kqcm = 1
2222! call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1,
2223 call qcmxmn('vegm ',veganl,slmskl,snoanl,icefl1,
2224 & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn,
2225 & vegjmx,vegjmn,vegsmx,vegsmn,epsveg,
2226 & rla,rlo,len,kqcm,percrit,lgchek,me)
2227! call qcmxmn('vetm ',vetanl,slianl,snoanl,icefl1,
2228 call qcmxmn('vetm ',vetanl,slmskl,snoanl,icefl1,
2229 & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn,
2230 & vetjmx,vetjmn,vetsmx,vetsmn,epsvet,
2231 & rla,rlo,len,kqcm,percrit,lgchek,me)
2232! call qcmxmn('sotm ',sotanl,slianl,snoanl,icefl1,
2233 call qcmxmn('sotm ',sotanl,slmskl,snoanl,icefl1,
2234 & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn,
2235 & sotjmx,sotjmn,sotsmx,sotsmn,epssot,
2236 & rla,rlo,len,kqcm,percrit,lgchek,me)
2237
2238 call qcmxmn('socm ',socanl,slmskl,snoanl,icefl1,
2239 & soclmx,soclmn,socomx,socomn,socimx,socimn,
2240 & socjmx,socjmn,socsmx,socsmn,epssoc,
2241 & rla,rlo,len,kqcm,percrit,lgchek,me)
2242!cwu [+8l] add sih, sic,
2243 call qcmxmn('sihm ',sihanl,slianl,snoanl,icefl1,
2244 & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn,
2245 & sihjmx,sihjmn,sihsmx,sihsmn,epssih,
2246 & rla,rlo,len,kqcm,percrit,lgchek,me)
2247! call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1,
2248! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn,
2249! & sicjmx,sicjmn,sicsmx,sicsmn,epssic,
2250! & rla,rlo,len,kqcm,percrit,lgchek,me)
2251!clu [+16l] add vmn, vmx, slp, abs
2252! call qcmxmn('vmnm ',vmnanl,slianl,snoanl,icefl1,
2253 call qcmxmn('vmnm ',vmnanl,slmskl,snoanl,icefl1,
2254 & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn,
2255 & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn,
2256 & rla,rlo,len,kqcm,percrit,lgchek,me)
2257! call qcmxmn('vmxm ',vmxanl,slianl,snoanl,icefl1,
2258 call qcmxmn('vmxm ',vmxanl,slmskl,snoanl,icefl1,
2259 & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn,
2260 & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx,
2261 & rla,rlo,len,kqcm,percrit,lgchek,me)
2262! call qcmxmn('slpm ',slpanl,slianl,snoanl,icefl1,
2263 call qcmxmn('slpm ',slpanl,slmskl,snoanl,icefl1,
2264 & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn,
2265 & slpjmx,slpjmn,slpsmx,slpsmn,epsslp,
2266 & rla,rlo,len,kqcm,percrit,lgchek,me)
2267 call qcmxmn('absm ',absanl,slianl,snoanl,icefl1,
2268 & abslmx,abslmn,absomx,absomn,absimx,absimn,
2269 & absjmx,absjmn,abssmx,abssmn,epsabs,
2270 & rla,rlo,len,kqcm,percrit,lgchek,me)
2271
2272!
2273 if(me == 0) then
2274 write(6,*) '=============='
2275 write(6,*) 'final results'
2276 write(6,*) '=============='
2277 endif
2278!
2279! foreward correction to tg3 and tsf at the last stage
2280!
2281! if(lprnt) print *,' tsfbc=',tsfanl(iprnt)
2282 if (use_ufo) then
2283!
2284! The tiled version of the substrate temperature is properly
2285! adjusted to the terrain. Only invoke when using the old
2286! global tg3 grib file.
2287!
2288 if ( index(fntg3c, "tileX.nc") == 0) then ! global file
2289 ztsfc = 1.
2290 call tsfcor(tg3anl,orogd,slmskl,ztsfc,len,rlapse)
2291 endif
2292 ztsfc = 0.
2293 call tsfcor(tsfanl,orogd,slmskw,ztsfc,len,rlapse)
2294 else
2295 ztsfc = 0.
2296 call tsfcor(tsfanl,orog,slmskw,ztsfc,len,rlapse)
2297 endif
2298! if(lprnt) print *,' tsfaf=',tsfanl(iprnt)
2299!
2300! check the final merged product
2301!
2302 if (monmer) then
2303 if(me == 0) then
2304 print *,' '
2305 print *,'monitor of updated surface fields'
2306 print *,' (includes angulation correction)'
2307 print *,' '
2308! call count(slianl,snoanl,len)
2309 print *,' '
2310 call monitr('tsfanl',tsfanl,slianl,snoanl,len)
2311 call monitr('albanl',albanl,slianl,snoanl,len)
2312 call monitr('aisanl',aisanl,slianl,snoanl,len)
2313 call monitr('snoanl',snoanl,slianl,snoanl,len)
2314 do k=1,lsoil
2315 call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len)
2316 call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len)
2317 enddo
2318 if (lsoil > 2) then
2319 call monitr('tg3anl',tg3anl,slianl,snoanl,len)
2320 call monitr('zoranl',zoranl,slianl,snoanl,len)
2321 endif
2322! if (gaus) then
2323 call monitr('cvaanl',cvanl ,slianl,snoanl,len)
2324 call monitr('cvbanl',cvbanl,slianl,snoanl,len)
2325 call monitr('cvtanl',cvtanl,slianl,snoanl,len)
2326! endif
2327 call monitr('slianl',slianl,slianl,snoanl,len)
2328! call monitr('plranl',plranl,slianl,snoanl,len)
2329 call monitr('orog ',orog ,slianl,snoanl,len)
2330 call monitr('cnpanl',cnpanl,slianl,snoanl,len)
2331 call monitr('veganl',veganl,slianl,snoanl,len)
2332 call monitr('vetanl',vetanl,slianl,snoanl,len)
2333 call monitr('sotanl',sotanl,slianl,snoanl,len)
2334 call monitr('socanl',socanl,slianl,snoanl,len)
2335!cwu [+2l] add sih, sic,
2336 call monitr('sihanl',sihanl,slianl,snoanl,len)
2337 call monitr('sicanl',sicanl,slianl,snoanl,len)
2338!clu [+4l] add vmn, vmx, slp, abs
2339 call monitr('vmnanl',vmnanl,slianl,snoanl,len)
2340 call monitr('vmxanl',vmxanl,slianl,snoanl,len)
2341 call monitr('slpanl',slpanl,slianl,snoanl,len)
2342 call monitr('absanl',absanl,slianl,snoanl,len)
2343 endif
2344 endif
2345!
2346 if (mondif) then
2347 allocate (tsffcsd(len), snofcsd(len), tg3fcsd(len), &
2348 & zorfcsd(len), slifcsd(len), aisfcsd(len), &
2349 & cnpfcsd(len), vegfcsd(len), vetfcsd(len), &
2350 & sotfcsd(len), socfcsd(len),sihfcsd(len), &
2351 & sicfcsd(len), &
2352 & vmnfcsd(len), vmxfcsd(len), slpfcsd(len), &
2353 & absfcsd(len))
2354 allocate (smcfcsd(len,lsoil), stcfcsd(len,lsoil), &
2355 & albfcsd(len,4))
2356 do i=1,len
2357 tsffcsd(i) = tsfanl(i) - tsffcs(i)
2358 snofcsd(i) = snoanl(i) - snofcs(i)
2359 tg3fcsd(i) = tg3anl(i) - tg3fcs(i)
2360 zorfcsd(i) = zoranl(i) - zorfcs(i)
2361! plrfcs(i) = plranl(i) - plrfcs(i)
2362! albfcs(i) = albanl(i) - albfcs(i)
2363 slifcsd(i) = slianl(i) - slifcs(i)
2364 aisfcsd(i) = aisanl(i) - aisfcs(i)
2365 cnpfcsd(i) = cnpanl(i) - cnpfcs(i)
2366 vegfcsd(i) = veganl(i) - vegfcs(i)
2367 vetfcsd(i) = vetanl(i) - vetfcs(i)
2368 sotfcsd(i) = sotanl(i) - sotfcs(i)
2369 socfcsd(i) = socanl(i) - socfcs(i)
2370!clu [+2l] add sih, sic
2371 sihfcsd(i) = sihanl(i) - sihfcs(i)
2372 sicfcsd(i) = sicanl(i) - sicfcs(i)
2373!clu [+4l] add vmn, vmx, slp, abs
2374 vmnfcsd(i) = vmnanl(i) - vmnfcs(i)
2375 vmxfcsd(i) = vmxanl(i) - vmxfcs(i)
2376 slpfcsd(i) = slpanl(i) - slpfcs(i)
2377 absfcsd(i) = absanl(i) - absfcs(i)
2378 enddo
2379 do j = 1,lsoil
2380 do i = 1,len
2381 smcfcsd(i,j) = smcanl(i,j) - smcfcs(i,j)
2382 stcfcsd(i,j) = stcanl(i,j) - stcfcs(i,j)
2383 enddo
2384 enddo
2385 do j = 1,4
2386 do i = 1,len
2387 albfcsd(i,j) = albanl(i,j) - albfcs(i,j)
2388 enddo
2389 enddo
2390!
2391! monitoring prints
2392!
2393 if(me == 0) then
2394 print *,' '
2395 print *,'monitor of difference'
2396 print *,' (includes angulation correction)'
2397 print *,' '
2398 call monitr('tsfdif', tsffcsd,slianl,snoanl,len)
2399 call monitr('albdif', albfcsd,slianl,snoanl,len)
2400 call monitr('albdif1',albfcsd,slianl,snoanl,len)
2401 call monitr('albdif2',albfcsd(1,2),slianl,snoanl,len)
2402 call monitr('albdif3',albfcsd(1,3),slianl,snoanl,len)
2403 call monitr('albdif4',albfcsd(1,4),slianl,snoanl,len)
2404 call monitr('aisdif', aisfcsd,slianl,snoanl,len)
2405 call monitr('snodif', snofcsd,slianl,snoanl,len)
2406 do k=1,lsoil
2407 call monitr(message('smcanl',k),smcfcsd(1,k),slianl,snoanl,len)
2408 call monitr(message('stcanl',k),stcfcsd(1,k),slianl,snoanl,len)
2409 enddo
2410 call monitr('tg3dif',tg3fcsd,slianl,snoanl,len)
2411 call monitr('zordif',zorfcsd,slianl,snoanl,len)
2412! if (gaus) then
2413 call monitr('cvadif',cvfcs ,slianl,snoanl,len)
2414 call monitr('cvbdif',cvbfcs,slianl,snoanl,len)
2415 call monitr('cvtdif',cvtfcs,slianl,snoanl,len)
2416! endif
2417 call monitr('slidif',slifcsd,slianl,snoanl,len)
2418! call monitr('plrdif',plrfcs,slianl,snoanl,len)
2419 call monitr('cnpdif',cnpfcsd,slianl,snoanl,len)
2420 call monitr('vegdif',vegfcsd,slianl,snoanl,len)
2421 call monitr('vetdif',vetfcsd,slianl,snoanl,len)
2422 call monitr('sotdif',sotfcsd,slianl,snoanl,len)
2423 call monitr('socdif',socfcsd,slianl,snoanl,len)
2424!cwu [+2l] add sih, sic
2425 call monitr('sihdif',sihfcsd,slianl,snoanl,len)
2426 call monitr('sicdif',sicfcsd,slianl,snoanl,len)
2427!clu [+4l] add vmn, vmx, slp, abs
2428 call monitr('vmndif',vmnfcsd,slianl,snoanl,len)
2429 call monitr('vmxdif',vmxfcsd,slianl,snoanl,len)
2430 call monitr('slpdif',slpfcsd,slianl,snoanl,len)
2431 call monitr('absdif',absfcsd,slianl,snoanl,len)
2432 endif
2433 deallocate (tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, &
2434 & aisfcsd, cnpfcsd, vegfcsd, vetfcsd, sotfcsd,socfcsd, &
2435 & sihfcsd, sicfcsd, vmnfcsd, vmxfcsd, slpfcsd, &
2436 & absfcsd)
2437 deallocate (smcfcsd, stcfcsd, albfcsd)
2438 endif
2439!
2440!
2441 do i=1,len
2442 tsffcs(i) = tsfanl(i)
2443 snofcs(i) = snoanl(i)
2444 tg3fcs(i) = tg3anl(i)
2445 zorfcs(i) = zoranl(i)
2446! plrfcs(i) = plranl(i)
2447! albfcs(i) = albanl(i)
2448 slifcs(i) = slianl(i)
2449 aisfcs(i) = aisanl(i)
2450 cvfcs(i) = cvanl(i)
2451 cvbfcs(i) = cvbanl(i)
2452 cvtfcs(i) = cvtanl(i)
2453 cnpfcs(i) = cnpanl(i)
2454 vegfcs(i) = veganl(i)
2455 vetfcs(i) = vetanl(i)
2456 sotfcs(i) = sotanl(i)
2457 socfcs(i) = socanl(i)
2458!clu [+4l] add vmn, vmx, slp, abs
2459 vmnfcs(i) = vmnanl(i)
2460 vmxfcs(i) = vmxanl(i)
2461 slpfcs(i) = slpanl(i)
2462 absfcs(i) = absanl(i)
2463 enddo
2464 do j = 1,lsoil
2465 do i = 1,len
2466 smcfcs(i,j) = smcanl(i,j)
2467 if (slifcs(i) > 0.0_kind_io8) then
2468 stcfcs(i,j) = stcanl(i,j)
2469 else
2470 stcfcs(i,j) = tsffcs(i)
2471 endif
2472 enddo
2473 enddo
2474! if(lprnt) print *,' stcfcs=',stcfcs(iprnt,:),'slifcs=', &
2475! & slifcs(iprnt)
2476 do j = 1,4
2477 do i = 1,len
2478 albfcs(i,j) = albanl(i,j)
2479 enddo
2480 enddo
2481 do j = 1,2
2482 do i = 1,len
2483 alffcs(i,j) = alfanl(i,j)
2484 enddo
2485 enddo
2486
2487!cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points
2488! crit = aislim
2489 do i=1,len
2490 if (slmskw(i) == zero) then
2491 crit = min_ice(i)
2492 if (sicanl(i) >= crit) then
2493 sihfcs(i) = sihanl(i)
2494 sitfcs(i) = tsffcs(i)
2495 if (sicfcs(i) >= crit) then
2496 tem1 = 1.0_kind_io8 / sicfcs(i)
2497 tsffcs(i) = (sicanl(i)*tsffcs(i)
2498 & + (sicfcs(i)-sicanl(i))*tgice) * tem1
2499 sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1
2500 sicfcs(i) = sicanl(i)
2501 else
2502 tsffcs(i) = tgice
2503 sitfcs(i) = tgice
2504 sicfcs(i) = sicanl(i)
2505 sihfcs(i) = sihnew
2506 endif
2507 else
2508 tsffcs(i) = tsfanl(i)
2509 sihfcs(i) = zero
2510 sicfcs(i) = zero
2511 slifcs(i) = zero
2512 sitfcs(i) = tsffcs(i)
2513 endif
2514 endif
2515 if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then
2516 print *,'warning: check, slifcs and sicfcs', &
2517 & slifcs(i),sicfcs(i)
2518 endif
2519 enddo
2520
2521! do i=1,len
2522! if (slifcs(i) < 1.5_kind_io8) then
2523! sihfcs(i) = 0.0_kind_io8
2524! sicfcs(i) = 0.0_kind_io8
2525! sitfcs(i) = tsffcs(i)
2526! else
2527! crit = min_ice(i)
2528! if (sicfcs(i) < crit) then
2529! print *,'warning: check, slifcs and sicfcs', &
2530! & slifcs(i),sicfcs(i)
2531! endif
2532! endif
2533! enddo
2534
2535!
2536! ensure the consistency between slc and smc
2537!
2538 do k=1, lsoil
2539 fixratio(k) = .false.
2540 if (fsmcl(k) < 99999.) fixratio(k) = .true.
2541 enddo
2542
2543 if(me == 0) then
2544 print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil)
2545 endif
2546
2547 do k=1, lsoil
2548 if(fixratio(k)) then
2549 do i = 1, len
2550 if(swratio(i,k) == -999.) then
2551 slcfcs(i,k) = smcfcs(i,k)
2552 else
2553 slcfcs(i,k) = swratio(i,k) * smcfcs(i,k)
2554 endif
2555 if (slifcs(i) /= 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points.
2556 enddo
2557 endif
2558 enddo
2559! set liquid soil moisture to a flag value of 1.0
2560 if (landice) then
2561 do i = 1, len
2562 if (slifcs(i) == 1.0 .and.
2563 & nint(vetfcs(i)) == veg_type_landice) then
2564 do k=1, lsoil
2565 slcfcs(i,k) = 1.0
2566 enddo
2567 endif
2568 enddo
2569 end if
2570!
2571! ensure the consistency between snwdph and sheleg
2572!
2573 if(fsnol < 99999.) then
2574 if(me == 0) then
2575 print *,'dbgx -- scale snwdph from sheleg'
2576 endif
2577 do i = 1, len
2578 if(slifcs(i) == 1.) swdfcs(i) = 10.* snofcs(i)
2579 enddo
2580 endif
2581
2582! sea ice model only uses the liquid equivalent depth.
2583! so update the physical depth only for display purposes.
2584! use the same 3:1 ratio used by ice model.
2585
2586 do i = 1, len
2587 if (slifcs(i) /= 1) swdfcs(i) = 3.*snofcs(i)
2588 enddo
2589
2590 do i = 1, len
2591 if(slifcs(i) == 1.) then
2592 if(snofcs(i) /= 0. .and. swdfcs(i) == 0.) then
2593 print *,'dbgx --scale snwdph from sheleg', &
2594 & i, swdfcs(i), snofcs(i)
2595 swdfcs(i) = 10.* snofcs(i)
2596 endif
2597 endif
2598 enddo
2599! landice mods - impose same minimum snow depth at
2600! landice as noah lsm. also ensure
2601! lower thermal boundary condition
2602! and skin t is no warmer than freezing
2603! after adjustment to terrain.
2604 if (landice) then
2605 do i = 1, len
2606 if (slifcs(i) == 1.0 .and. &
2607 & nint(vetfcs(i)) == veg_type_landice) then
2608 snofcs(i) = max(snofcs(i),100.0) ! in mm
2609 swdfcs(i) = max(swdfcs(i),1000.0) ! in mm
2610 tg3fcs(i) = min(tg3fcs(i),273.15)
2611 tsffcs(i) = min(tsffcs(i),273.15)
2612 endif
2613 enddo
2614 endif
2615 do i=1,len
2616 if (nint(slmskl(i)) == 1 .and. nint(slmskw(i)) == 0) then
2617 slifcs(i) = slmskl(i) ! resetting slmsk to land value where land/wate/ice coexist
2618 endif
2619 enddo
2620!
2621! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt)
2622! if(lprnt) print *,' stcfcsend=',stcfcs(iprnt,:)
2623! if(lprnt) print *,' slifcsend=',slifcs(iprnt)
2624 return
2625 end subroutine sfccycle
2626
2630 subroutine count(slimsk,sno,ijmax)
2631 use machine , only : kind_io8,kind_io4
2632 implicit none
2633 real (kind=kind_io8) rl3,rl1,rl0,rl2,rl6,rl7,rl4,rl5
2634 integer l8,l7,l1,l2,ijmax,l0,l3,l5,l6,l4,ij
2635!
2636 real (kind=kind_io8) slimsk(1),sno(1)
2637!
2638! count number of points for the four surface conditions
2639!
2640 l0 = 0
2641 l1 = 0
2642 l2 = 0
2643 l3 = 0
2644 l4 = 0
2645 do ij=1,ijmax
2646 if(slimsk(ij).eq.0.) l1 = l1 + 1
2647 if(slimsk(ij).eq.1. .and. sno(ij).le.0.) l0 = l0 + 1
2648 if(slimsk(ij).eq.2. .and. sno(ij).le.0.) l2 = l2 + 1
2649 if(slimsk(ij).eq.1. .and. sno(ij).gt.0.) l3 = l3 + 1
2650 if(slimsk(ij).eq.2. .and. sno(ij).gt.0.) l4 = l4 + 1
2651 enddo
2652 l5 = l0 + l3
2653 l6 = l2 + l4
2654 l7 = l1 + l6
2655 l8 = l1 + l5 + l6
2656 rl0 = float(l0) / float(l8)*100.
2657 rl3 = float(l3) / float(l8)*100.
2658 rl1 = float(l1) / float(l8)*100.
2659 rl2 = float(l2) / float(l8)*100.
2660 rl4 = float(l4) / float(l8)*100.
2661 rl5 = float(l5) / float(l8)*100.
2662 rl6 = float(l6) / float(l8)*100.
2663 rl7 = float(l7) / float(l8)*100.
2664 print *,'1) no. of not snow-covered land points ',l0,' ',rl0,' '
2665 print *,'2) no. of snow covered land points ',l3,' ',rl3,' '
2666 print *,'3) no. of open sea points ',l1,' ',rl1,' '
2667 print *,'4) no. of not snow-covered seaice points ',l2,' ',rl2,' '
2668 print *,'5) no. of snow covered sea ice points ',l4,' ',rl4,' '
2669 print *,' '
2670 print *,'6) no. of land points ',l5,' ',rl5,' '
2671 print *,'7) no. sea points (including sea ice) ',l7,' ',rl7,' '
2672 print *,' (no. of sea ice points) (',l6,')',' ',rl6,' '
2673 print *,' '
2674 print *,'9) no. of total grid points ',l8
2675! print *,' '
2676! print *,' '
2677
2678!
2679! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt)
2680 return
2681 end
2682
2684 subroutine monitr(lfld,fld,slimsk,sno,ijmax)
2685 use machine , only : kind_io8,kind_io4
2686 implicit none
2687 integer ij,n,ijmax
2688!
2689 real (kind=kind_io8) fld(ijmax), slimsk(ijmax),sno(ijmax)
2690!
2691 real (kind=kind_io8) rmax(5),rmin(5)
2692 character(len=*) lfld
2693!
2694! find max/min
2695!
2696 do n=1,5
2697 rmax(n) = -9.e20
2698 rmin(n) = 9.e20
2699 enddo
2700!
2701 do ij=1,ijmax
2702 if(slimsk(ij).eq.0.) then
2703 rmax(1) = max(rmax(1), fld(ij))
2704 rmin(1) = min(rmin(1), fld(ij))
2705 elseif(slimsk(ij).eq.1.) then
2706 if(sno(ij).le.0.) then
2707 rmax(2) = max(rmax(2), fld(ij))
2708 rmin(2) = min(rmin(2), fld(ij))
2709 else
2710 rmax(4) = max(rmax(4), fld(ij))
2711 rmin(4) = min(rmin(4), fld(ij))
2712 endif
2713 else
2714 if(sno(ij).le.0.) then
2715 rmax(3) = max(rmax(3), fld(ij))
2716 rmin(3) = min(rmin(3), fld(ij))
2717 else
2718 rmax(5) = max(rmax(5), fld(ij))
2719 rmin(5) = min(rmin(5), fld(ij))
2720 endif
2721 endif
2722 enddo
2723!
2724 print 100,lfld
2725 print 101,rmax(1),rmin(1)
2726 print 102,rmax(2),rmin(2), rmax(4), rmin(4)
2727 print 103,rmax(3),rmin(3), rmax(5), rmin(5)
2728!
2729! print 102,rmax(2),rmin(2)
2730! print 103,rmax(3),rmin(3)
2731! print 104,rmax(4),rmin(4)
2732! print 105,rmax(5),rmin(5)
2733 100 format('0 *** ',a8,' ***')
2734 101 format(' open sea ......... max=',e12.4,' min=',e12.4)
2735 102 format(' land nosnow/snow .. max=',e12.4,' min=',e12.4
2736 &, ' max=',e12.4,' min=',e12.4)
2737 103 format(' seaice nosnow/snow max=',e12.4,' min=',e12.4
2738 &, ' max=',e12.4,' min=',e12.4)
2739!
2740! 100 format('0',2x,'*** ',a8,' ***')
2741! 102 format(2x,' land without snow ..... max=',e12.4,' min=',e12.4)
2742! 103 format(2x,' seaice without snow ... max=',e12.4,' min=',e12.4)
2743! 104 format(2x,' land with snow ........ max=',e12.4,' min=',e12.4)
2744! 105 format(2x,' sea ice with snow ..... max=',e12.4,' min=',e12.4)
2745!
2746 return
2747 end
2748
2751 subroutine dayoyr(iyr,imo,idy,ldy)
2752 implicit none
2753 integer ldy,i,idy,iyr,imo
2754!
2755! this routine figures out the day of the year given imo and idy
2756!
2757 integer month(13)
2758 data month/0,31,28,31,30,31,30,31,31,30,31,30,31/
2759 if(mod(iyr,4).eq.0) month(3) = 29
2760 ldy = idy
2761 do i = 1, imo
2762 ldy = ldy + month(i)
2763 enddo
2764 return
2765 end
2766
2769 subroutine hmskrd(lugb,imsk,jmsk,fnmskh, &
2770 & kpds5,slmskh,gausm,blnmsk,bltmsk,me)
2771 use machine , only : kind_io8,kind_io4
2772 use sfccyc_module, only : mdata, xdata, ydata
2773 implicit none
2774 integer kpds5,me,i,imsk,jmsk,lugb
2775!
2776 character*500 fnmskh
2777!
2778 real (kind=kind_io8) slmskh(mdata)
2779 logical gausm
2780 real (kind=kind_io8) blnmsk,bltmsk
2781!
2782 imsk = xdata
2783 jmsk = ydata
2784
2785 if (me .eq. 0) then
2786 write(6,*)' imsk=',imsk,' jmsk=',jmsk,' xdata=',xdata,' ydata='
2787 &, ydata
2788 endif
2789
2790 call fixrdg(lugb,imsk,jmsk,fnmskh,
2791 & kpds5,slmskh,gausm,blnmsk,bltmsk,me)
2792
2793
2794 do i=1,imsk*jmsk
2795 slmskh(i) = nint(slmskh(i))
2796 enddo
2797!
2798 return
2799 end
2800
2802 subroutine fixrdg(lugb,idim,jdim,fngrib, &
2803 & kpds5,gdata,gaus,blno,blto,me)
2804 use machine , only : kind_io8,kind_dbl_prec,kind_sngl_prec
2805 use sfccyc_module, only : mdata
2806 implicit none
2807 integer lgrib,n,lskip,jret,j,ndata,lugi,jdim,idim,lugb,
2808 & iret, me,kpds5,kdata,i
2809!
2810 character*(*) fngrib
2811!
2812 real (kind=kind_io8) gdata(idim*jdim)
2813 logical gaus
2814 real (kind=kind_io8) blno,blto
2815 real (kind=kind_dbl_prec), allocatable :: data8(:)
2816!
2817 logical*1, allocatable :: lbms(:)
2818!
2819 integer kpds(200),kgds(200)
2820 integer jpds(200),jgds(200), kpds0(200)
2821!
2822 allocate(data8(1:idim*jdim))
2823 allocate(lbms(1:mdata))
2824 kpds = 0
2825 kgds = 0
2826 jpds = 0
2827 jgds = 0
2828 kpds0 = 0
2829!
2830! if(me .eq. 0) then
2831! write(6,*) ' '
2832! write(6,*) '************************************************'
2833! endif
2834!
2835 close(lugb)
2836 call baopenr(lugb,fngrib,iret)
2837 if (iret .ne. 0) then
2838 write(6,*) ' FATAL ERROR: in opening file ',trim(fngrib)
2839 print *,'FATAL ERROR: in opening file ',trim(fngrib)
2840 call abort
2841 endif
2842 if (me .eq. 0) write(6,*) ' file ',trim(fngrib),
2843 & ' opened. unit=',lugb
2844 lugi = 0
2845 lskip = -1
2846 n = 0
2847 jpds = -1
2848 jgds = -1
2849 jpds(5) = kpds5
2850 kpds = jpds
2851!
2852 call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata,
2853 & lskip,kpds,kgds,iret)
2854!
2855 if(me .eq. 0) then
2856 write(6,*) ' first grib record.'
2857 write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10)
2858 write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20)
2859 write(6,*) ' kpds(21- )=',(kpds(j),j=21,22)
2860 endif
2861!
2862 kpds0=jpds
2863 kpds0(4)=-1
2864 kpds0(18)=-1
2865 if(iret.ne.0) then
2866 write(6,*) ' FATAL ERROR: in getgbh. iret: ', iret
2867 if (iret == 99) write(6,*) ' Field not found.'
2868 call abort
2869 endif
2870!
2871 jpds = kpds0
2872 lskip = -1
2873 kdata=idim*jdim
2874 call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip,
2875 & kpds,kgds,lbms,data8,jret)
2876!
2877 if(jret == 0) then
2878 if(ndata.eq.0) then
2879 write(6,*) ' FATAL ERROR: in getgb'
2880 write(6,*) ' kpds=',kpds
2881 write(6,*) ' kgds=',kgds
2882 call abort
2883 endif
2884 idim = kgds(2)
2885 jdim = kgds(3)
2886 gaus = kgds(1).eq.4
2887 blno = kgds(5)*1.d-3
2888 blto = kgds(4)*1.d-3
2889 gdata(1:idim*jdim) = data8(1:idim*jdim)
2890 if (me == 0) write(6,*) 'idim,jdim=',idim,jdim
2891 &, ' gaus=',gaus,' blno=',blno,' blto=',blto
2892 else
2893 if (me ==. 0) write(6,*) 'idim,jdim=',idim,jdim
2894 &, ' gaus=',gaus,' blno=',blno,' blto=',blto
2895 write(6,*) ' FATAL ERROR in getgb : jret=',jret
2896 write(6,*) ' kpds(13)=',kpds(13),' kpds(15)=',kpds(15)
2897 call abort
2898 endif
2899!
2900 deallocate(data8)
2901 deallocate(lbms)
2902 return
2903 end
2904
2907 subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me)
2908 use machine , only : kind_io8,kind_io4
2909 implicit none
2910 integer j,me,kgds11
2911 real (kind=kind_io8) f0lon,f0lat,elon,dlon,dlat,rslat,wlon,rnlat
2912!
2913! get area of the grib record
2914!
2915 integer kgds(22)
2916 logical ijordr
2917!
2918 if (me .eq. 0) then
2919 write(6,*) ' kgds( 1-12)=',(kgds(j),j= 1,12)
2920 write(6,*) ' kgds(13-22)=',(kgds(j),j=13,22)
2921 endif
2922!
2923 if(kgds(1).eq.0) then ! lat/lon grid
2924!
2925 if (me .eq. 0) write(6,*) 'lat/lon grid'
2926 dlat = float(kgds(10)) * 0.001
2927 dlon = float(kgds( 9)) * 0.001
2928 f0lon = float(kgds(5)) * 0.001
2929 f0lat = float(kgds(4)) * 0.001
2930 kgds11 = kgds(11)
2931 if(kgds11.ge.128) then
2932 wlon = f0lon - dlon*(kgds(2)-1)
2933 elon = f0lon
2934 if(dlon*kgds(2).gt.359.99) then
2935 wlon =f0lon - dlon*kgds(2)
2936 endif
2937 dlon = -dlon
2938 kgds11 = kgds11 - 128
2939 else
2940 wlon = f0lon
2941 elon = f0lon + dlon*(kgds(2)-1)
2942 if(dlon*kgds(2).gt.359.99) then
2943 elon = f0lon + dlon*kgds(2)
2944 endif
2945 endif
2946 if(kgds11.ge.64) then
2947 rnlat = f0lat + dlat*(kgds(3)-1)
2948 rslat = f0lat
2949 kgds11 = kgds11 - 64
2950 else
2951 rnlat = f0lat
2952 rslat = f0lat - dlat*(kgds(3)-1)
2953 dlat = -dlat
2954 endif
2955 if(kgds11.ge.32) then
2956 ijordr = .false.
2957 else
2958 ijordr = .true.
2959 endif
2960
2961 if(wlon.gt.180.) wlon = wlon - 360.
2962 if(elon.gt.180.) elon = elon - 360.
2963 wlon = nint(wlon*1000.) * 0.001
2964 elon = nint(elon*1000.) * 0.001
2965 rslat = nint(rslat*1000.) * 0.001
2966 rnlat = nint(rnlat*1000.) * 0.001
2967 return
2968!
2969 elseif(kgds(1).eq.1) then ! mercator projection
2970 write(6,*) 'FATAL ERROR: cannot process'
2971 write(6,*) 'mercator grid.'
2972 call abort
2973!
2974 elseif(kgds(1).eq.2) then ! gnomonic projection
2975 write(6,*) 'FATAL ERROR: cannot process'
2976 write(6,*) 'gnomonic grid.'
2977 call abort
2978!
2979 elseif(kgds(1).eq.3) then ! lambert conformal
2980 write(6,*) 'FATAL ERROR: cannot process'
2981 write(6,*) 'lambert conformal grid.'
2982 call abort
2983 elseif(kgds(1).eq.4) then ! gaussian grid
2984!
2985 if (me .eq. 0) write(6,*) 'gaussian grid'
2986 dlat = 99.
2987 dlon = float(kgds( 9)) / 1000.0
2988 f0lon = float(kgds(5)) / 1000.0
2989 f0lat = 99.
2990 kgds11 = kgds(11)
2991 if(kgds11.ge.128) then
2992 wlon = f0lon
2993 elon = f0lon
2994 if(dlon*kgds(2).gt.359.99) then
2995 wlon = f0lon - dlon*kgds(2)
2996 endif
2997 dlon = -dlon
2998 kgds11 = kgds11-128
2999 else
3000 wlon = f0lon
3001 elon = f0lon + dlon*(kgds(2)-1)
3002 if(dlon*kgds(2).gt.359.99) then
3003 elon = f0lon + dlon*kgds(2)
3004 endif
3005 endif
3006 if(kgds11.ge.64) then
3007 rnlat = 99.
3008 rslat = 99.
3009 kgds11 = kgds11 - 64
3010 else
3011 rnlat = 99.
3012 rslat = 99.
3013 dlat = -99.
3014 endif
3015 if(kgds11.ge.32) then
3016 ijordr = .false.
3017 else
3018 ijordr = .true.
3019 endif
3020 return
3021!
3022 elseif(kgds(1).eq.5) then ! polar strereographic
3023 write(6,*) 'FATAL ERROR: cannot process'
3024 write(6,*) 'polar stereographic grid.'
3025 call abort
3026 return
3027!
3028 elseif(kgds(1).eq.13) then ! oblique lambert conformal
3029 write(6,*) 'FATAL ERROR: cannot process'
3030 write(6,*) 'oblique lambert conformal grid.'
3031 call abort
3032!
3033 elseif(kgds(1).eq.50) then ! spherical coefficient
3034 write(6,*) 'FATAL ERROR: cannot process'
3035 write(6,*) 'spherical coefficient grid.'
3036 call abort
3037 return
3038!
3039 elseif(kgds(1).eq.90) then ! space view perspective
3040! (orthographic grid)
3041 write(6,*) 'FATAL ERROR: cannot process'
3042 write(6,*) 'space view perspective grid.'
3043 call abort
3044 return
3045!
3046 else ! unknown projection. abort.
3047 write(6,*) 'FATAL ERROR: Unknown map projection.'
3048 write(6,*) 'kgds(1)=',kgds(1)
3049 print *,'FATAL ERROR: Unknown map projection.'
3050 print *,'kgds(1)=',kgds(1)
3051 call abort
3052 endif
3053!
3054 return
3055 end
3056
3058 subroutine subst(data,imax,jmax,dlon,dlat,ijordr)
3059 use machine , only : kind_io8,kind_io4
3060 implicit none
3061 integer i,j,ii,jj,jmax,imax,iret
3062 real (kind=kind_io8) dlat,dlon
3063!
3064 logical ijordr
3065!
3066 real (kind=kind_io8) data(imax,jmax)
3067 real (kind=kind_io8), allocatable :: work(:,:)
3068!
3069 if(.not.ijordr.or.
3070 & (ijordr.and.(dlat.gt.0..or.dlon.lt.0.))) then
3071 allocate (work(imax,jmax))
3072
3073 if(.not.ijordr) then
3074 do j=1,jmax
3075 do i=1,imax
3076 work(i,j) = data(j,i)
3077 enddo
3078 enddo
3079 else
3080 do j=1,jmax
3081 do i=1,imax
3082 work(i,j) = data(i,j)
3083 enddo
3084 enddo
3085 endif
3086 if (dlat > 0.0) then
3087 if (dlon > 0.0) then
3088 do j=1,jmax
3089 jj = jmax - j + 1
3090 do i=1,imax
3091 data(i,jj) = work(i,j)
3092 enddo
3093 enddo
3094 else
3095 do i=1,imax
3096 data(imax-i+1,jj) = work(i,j)
3097 enddo
3098 endif
3099 else
3100 if (dlon > 0.0) then
3101 do j=1,jmax
3102 do i=1,imax
3103 data(i,j) = work(i,j)
3104 enddo
3105 enddo
3106 else
3107 do j=1,jmax
3108 do i=1,imax
3109 data(imax-i+1,j) = work(i,j)
3110 enddo
3111 enddo
3112 endif
3113 endif
3114 deallocate (work, stat=iret)
3115 endif
3116 return
3117 end
3118
3122 subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,&
3123 & gauout,len,lmask,rslmsk,slmask &
3124 &, outlat, outlon,me)
3125 use machine , only : kind_io8,kind_io4
3126 use sfccyc_module , only : num_threads
3127 implicit none
3128 real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, &
3129 & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, &
3130 & wi1j2,wi2j1,rlat,rlon,aphi, &
3131 & rnume,alamd,denom
3132 integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, &
3133 & ii,i1,i2,kmami,it
3134 integer nx,kxs,kxt
3135 integer, allocatable, save :: imxnx(:)
3136 integer, allocatable :: ifill(:)
3137!
3138 real (kind=kind_io8) outlon(len),outlat(len),gauout(len), &
3139 & slmask(len)
3140 real (kind=kind_io8) regin(imxin,jmxin),rslmsk(imxin,jmxin)
3141!
3142 real (kind=kind_io8) rinlat(jmxin), rinlon(imxin)
3143 integer iindx1(len), iindx2(len)
3144 integer jindx1(len), jindx2(len)
3145 real (kind=kind_io8) ddx(len), ddy(len), wrk(len)
3146!
3147 logical lmask
3148!
3149 logical first
3150 data first /.true./
3151 save first
3152!
3153 integer len_thread_m, len_thread, i1_t, i2_t
3154!
3155 if (first) then
3156 first = .false.
3157 if (.not. allocated(imxnx)) allocate (imxnx(num_threads))
3158 endif
3159!
3160! if (me == 0) print *,' num_threads =',num_threads,' me=',me
3161!
3162! if(me .eq. 0) then
3163! print *,'rlon=',rlon,' me=',me
3164! print *,'rlat=',rlat,' me=',me,' imxin=',imxin,' jmxin=',jmxin
3165! endif
3166!
3167! do j=1,jmxin
3168! if(rlat.gt.0.) then
3169! rinlat(j) = rlat - float(j-1)*dlain
3170! else
3171! rinlat(j) = rlat + float(j-1)*dlain
3172! endif
3173! enddo
3174!
3175! if (me .eq. 0) then
3176! print *,'rinlat='
3177! print *,(rinlat(j),j=1,jmxin)
3178! print *,'rinlon='
3179! print *,(rinlon(i),i=1,imxin)
3180!
3181! print *,'outlat='
3182! print *,(outlat(j),j=1,len)
3183! print *,(outlon(j),j=1,len)
3184! endif
3185!
3186! do i=1,imxin
3187! rinlon(i) = rlon + float(i-1)*dloin
3188! enddo
3189!
3190! print *,'rinlon='
3191! print *,(rinlon(i),i=1,imxin)
3192!
3193 len_thread_m = (len+num_threads-1) / num_threads
3194
3195 if (inttyp /=1) allocate (ifill(num_threads))
3196!
3197!$omp parallel do default(none)
3198!$omp+private(i1_t,i2_t,len_thread,it,i,ii,i1,i2)
3199!$omp+private(j,j1,j2,jq,ix,jy,nx,kxs,kxt,kmami)
3200!$omp+private(alamd,denom,rnume,aphi,x,y,wsum,wsumiv,sum1,sum2)
3201!$omp+private(sum3,sum4,wi1j1,wi2j1,wi1j2,wi2j2,wei1,wei2,wei3,wei4)
3202!$omp+private(sumn,sums)
3203!$omp+shared(imxin,jmxin,ifill)
3204!$omp+shared(outlon,outlat,wrk,iindx1,rinlon,jindx1,rinlat,ddx,ddy)
3205!$omp+shared(rlon,rlat,regin,gauout,imxnx)
3206!$omp+private(tem)
3207!$omp+shared(num_threads,len_thread_m,len,lmask,iindx2,jindx2,rslmsk)
3208!$omp+shared(inttyp,me,slmask)
3209!
3210 do it=1,num_threads ! start of threaded loop ...................
3211 i1_t = (it-1)*len_thread_m+1
3212 i2_t = min(i1_t+len_thread_m-1,len)
3213 len_thread = i2_t-i1_t+1
3214!
3215! find i-index for interpolation
3216!
3217 do i=i1_t, i2_t
3218 alamd = outlon(i)
3219 if (alamd .lt. rlon) alamd = alamd + 360.0
3220 if (alamd .gt. 360.0+rlon) alamd = alamd - 360.0
3221 wrk(i) = alamd
3222 iindx1(i) = imxin
3223 enddo
3224 do i=i1_t,i2_t
3225 do ii=1,imxin
3226 if(wrk(i) .ge. rinlon(ii)) iindx1(i) = ii
3227 enddo
3228 enddo
3229 do i=i1_t,i2_t
3230 i1 = iindx1(i)
3231 if (i1 .lt. 1) i1 = imxin
3232 i2 = i1 + 1
3233 if (i2 .gt. imxin) i2 = 1
3234 iindx1(i) = i1
3235 iindx2(i) = i2
3236 denom = rinlon(i2) - rinlon(i1)
3237 if(denom.lt.0.) denom = denom + 360.
3238 rnume = wrk(i) - rinlon(i1)
3239 if(rnume.lt.0.) rnume = rnume + 360.
3240 ddx(i) = rnume / denom
3241 enddo
3242!
3243! find j-index for interplation
3244!
3245 if(rlat.gt.0.) then
3246 do j=i1_t,i2_t
3247 jindx1(j)=0
3248 enddo
3249 do jx=1,jmxin
3250 do j=i1_t,i2_t
3251 if(outlat(j).le.rinlat(jx)) jindx1(j) = jx
3252 enddo
3253 enddo
3254 do j=i1_t,i2_t
3255 jq = jindx1(j)
3256 aphi=outlat(j)
3257 if(jq.ge.1 .and. jq .lt. jmxin) then
3258 j2=jq+1
3259 j1=jq
3260 ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1))
3261 elseif (jq .eq. 0) then
3262 j2=1
3263 j1=1
3264 if(abs(90.-rinlat(j1)).gt.0.001) then
3265 ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1))
3266 else
3267 ddy(j)=0.0
3268 endif
3269 else
3270 j2=jmxin
3271 j1=jmxin
3272 if(abs(-90.-rinlat(j1)).gt.0.001) then
3273 ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1))
3274 else
3275 ddy(j)=0.0
3276 endif
3277 endif
3278 jindx1(j)=j1
3279 jindx2(j)=j2
3280 enddo
3281 else
3282 do j=i1_t,i2_t
3283 jindx1(j) = jmxin+1
3284 enddo
3285 do jx=jmxin,1,-1
3286 do j=i1_t,i2_t
3287 if(outlat(j).le.rinlat(jx)) jindx1(j) = jx
3288 enddo
3289 enddo
3290 do j=i1_t,i2_t
3291 jq = jindx1(j)
3292 aphi=outlat(j)
3293 if(jq.gt.1 .and. jq .le. jmxin) then
3294 j2=jq
3295 j1=jq-1
3296 ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1))
3297 elseif (jq .eq. 1) then
3298 j2=1
3299 j1=1
3300 if(abs(-90.-rinlat(j1)).gt.0.001) then
3301 ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1))
3302 else
3303 ddy(j)=0.0
3304 endif
3305 else
3306 j2=jmxin
3307 j1=jmxin
3308 if(abs(90.-rinlat(j1)).gt.0.001) then
3309 ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1))
3310 else
3311 ddy(j)=0.0
3312 endif
3313 endif
3314 jindx1(j)=j1
3315 jindx2(j)=j2
3316 enddo
3317 endif
3318!
3319! if (me .eq. 0 .and. inttyp .eq. 1) then
3320! print *,'la2ga'
3321! print *,'iindx1'
3322! print *,(iindx1(n),n=1,len)
3323! print *,'iindx2'
3324! print *,(iindx2(n),n=1,len)
3325! print *,'jindx1'
3326! print *,(jindx1(n),n=1,len)
3327! print *,'jindx2'
3328! print *,(jindx2(n),n=1,len)
3329! print *,'ddy'
3330! print *,(ddy(n),n=1,len)
3331! print *,'ddx'
3332! print *,(ddx(n),n=1,len)
3333! endif
3334!
3335 sum1 = 0.
3336 sum2 = 0.
3337 sum3 = 0.
3338 sum4 = 0.
3339 if (lmask) then
3340 wei1 = 0.
3341 wei2 = 0.
3342 wei3 = 0.
3343 wei4 = 0.
3344 do i=1,imxin
3345 sum1 = sum1 + regin(i,1) * rslmsk(i,1)
3346 sum2 = sum2 + regin(i,jmxin) * rslmsk(i,jmxin)
3347 wei1 = wei1 + rslmsk(i,1)
3348 wei2 = wei2 + rslmsk(i,jmxin)
3349!
3350 sum3 = sum3 + regin(i,1) * (1.0-rslmsk(i,1))
3351 sum4 = sum4 + regin(i,jmxin) * (1.0-rslmsk(i,jmxin))
3352 wei3 = wei3 + (1.0-rslmsk(i,1))
3353 wei4 = wei4 + (1.0-rslmsk(i,jmxin))
3354 enddo
3355!
3356 if(wei1.gt.0.) then
3357 sum1 = sum1 / wei1
3358 else
3359 sum1 = 0.
3360 endif
3361 if(wei2.gt.0.) then
3362 sum2 = sum2 / wei2
3363 else
3364 sum2 = 0.
3365 endif
3366 if(wei3.gt.0.) then
3367 sum3 = sum3 / wei3
3368 else
3369 sum3 = 0.
3370 endif
3371 if(wei4.gt.0.) then
3372 sum4 = sum4 / wei4
3373 else
3374 sum4 = 0.
3375 endif
3376 else
3377 do i=1,imxin
3378 sum1 = sum1 + regin(i,1)
3379 sum2 = sum2 + regin(i,jmxin)
3380 enddo
3381 sum1 = sum1 / imxin
3382 sum2 = sum2 / imxin
3383 sum3 = sum1
3384 sum4 = sum2
3385 endif
3386!
3387! print *,' sum1=',sum1,' sum2=',sum2
3388! *,' sum3=',sum3,' sum4=',sum4
3389! print *,' rslmsk=',(rslmsk(i,1),i=1,imxin)
3390! print *,' slmask=',(slmask(i),i=1,imxout)
3391! *,' j1=',jindx1(1),' j2=',jindx2(1)
3392!
3393!
3394! inttyp=1 take the closest point value
3395!
3396 if(inttyp.eq.1) then
3397
3398 do i=i1_t,i2_t
3399 jy = jindx1(i)
3400 if(ddy(i) .ge. 0.5) jy = jindx2(i)
3401 ix = iindx1(i)
3402 if(ddx(i) .ge. 0.5) ix = iindx2(i)
3403!
3404!cggg start
3405!
3406 if (.not. lmask) then
3407
3408 gauout(i) = regin(ix,jy)
3409
3410 else
3411
3412 if(slmask(i).eq.rslmsk(ix,jy)) then
3413
3414 gauout(i) = regin(ix,jy)
3415
3416 else
3417
3418 i1 = ix
3419 j1 = jy
3420
3421! spiral around until matching mask is found.
3422 do nx=1,jmxin*imxin/2
3423 kxs=sqrt(4*nx-2.5)
3424 kxt=nx-int(kxs**2/4+1)
3425 select case(mod(kxs,4))
3426 case(1)
3427 ix=i1-kxs/4+kxt
3428 jx=j1-kxs/4
3429 case(2)
3430 ix=i1+1+kxs/4
3431 jx=j1-kxs/4+kxt
3432 case(3)
3433 ix=i1+1+kxs/4-kxt
3434 jx=j1+1+kxs/4
3435 case default
3436 ix=i1-kxs/4
3437 jx=j1+kxs/4-kxt
3438 end select
3439 if(jx.lt.1) then
3440 ix=ix+imxin/2
3441 jx=2-jx
3442 elseif(jx.gt.jmxin) then
3443 ix=ix+imxin/2
3444 jx=2*jmxin-jx
3445 endif
3446 ix=modulo(ix-1,imxin)+1
3447 if(slmask(i).eq.rslmsk(ix,jx)) then
3448 gauout(i) = regin(ix,jx)
3449 go to 81
3450 endif
3451 enddo
3452
3453!cggg here, set the gauout value to be 0, and let's sarah's land
3454!cggg routine assign a default.
3455
3456 if (num_threads == 1) then
3457 print*,'no matching mask found ',i,i1,j1,ix,jx &
3458 &, ' slmask=',slmask(i),' me=',me &
3459 &, ' outlon=',outlon(i),' outlat=',outlat(i)
3460 &, 'set to default value.'
3461 endif
3462 gauout(i) = 0.0
3463
3464
3465 81 continue
3466
3467 end if
3468
3469 end if
3470
3471!cggg end
3472
3473 enddo
3474! kmami=1
3475! if (me == 0 .and. num_threads == 1)
3476! & call maxmin(gauout(i1_t),len_thread,kmami)
3477 else ! nearest neighbor interpolation
3478
3479!
3480! quasi-bilinear interpolation
3481!
3482 ifill(it) = 0
3483 imxnx(it) = 0
3484 do i=i1_t,i2_t
3485 y = ddy(i)
3486 j1 = jindx1(i)
3487 j2 = jindx2(i)
3488 x = ddx(i)
3489 i1 = iindx1(i)
3490 i2 = iindx2(i)
3491!
3492 wi1j1 = (1.-x) * (1.-y)
3493 wi2j1 = x *( 1.-y)
3494 wi1j2 = (1.-x) * y
3495 wi2j2 = x * y
3496!
3497 tem = 4.*slmask(i) - rslmsk(i1,j1) - rslmsk(i2,j1)
3498 & - rslmsk(i1,j2) - rslmsk(i2,j2)
3499 if(lmask .and. abs(tem) .gt. 0.01) then
3500 if(slmask(i).eq.1.) then
3501 wi1j1 = wi1j1 * rslmsk(i1,j1)
3502 wi2j1 = wi2j1 * rslmsk(i2,j1)
3503 wi1j2 = wi1j2 * rslmsk(i1,j2)
3504 wi2j2 = wi2j2 * rslmsk(i2,j2)
3505 else
3506 wi1j1 = wi1j1 * (1.0-rslmsk(i1,j1))
3507 wi2j1 = wi2j1 * (1.0-rslmsk(i2,j1))
3508 wi1j2 = wi1j2 * (1.0-rslmsk(i1,j2))
3509 wi2j2 = wi2j2 * (1.0-rslmsk(i2,j2))
3510 endif
3511 endif
3512!
3513 wsum = wi1j1 + wi2j1 + wi1j2 + wi2j2
3514 wrk(i) = wsum
3515 if(wsum.ne.0.) then
3516 wsumiv = 1./wsum
3517!
3518 if(j1.ne.j2) then
3519 gauout(i) = (wi1j1*regin(i1,j1) + wi2j1*regin(i2,j1) +
3520 & wi1j2*regin(i1,j2) + wi2j2*regin(i2,j2))
3521 & *wsumiv
3522 else
3523!
3524 if (rlat .gt. 0.0) then
3525 if (slmask(i) .eq. 1.0) then
3526 sumn = sum1
3527 sums = sum2
3528 else
3529 sumn = sum3
3530 sums = sum4
3531 endif
3532 if( j1 .eq. 1) then
3533 gauout(i) = (wi1j1*sumn +wi2j1*sumn +
3534 & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2))
3535 & * wsumiv
3536 elseif (j1 .eq. jmxin) then
3537 gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+
3538 & wi1j2*sums +wi2j2*sums )
3539 & * wsumiv
3540 endif
3541 else
3542 if (slmask(i) .eq. 1.0) then
3543 sums = sum1
3544 sumn = sum2
3545 else
3546 sums = sum3
3547 sumn = sum4
3548 endif
3549 if( j1 .eq. 1) then
3550 gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+
3551 & wi1j2*sums +wi2j2*sums )
3552 & * wsumiv
3553 elseif (j1 .eq. jmxin) then
3554 gauout(i) = (wi1j1*sumn +wi2j1*sumn +
3555 & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2))
3556 & * wsumiv
3557 endif
3558 endif
3559 endif ! if j1 .ne. j2
3560 endif
3561 enddo
3562 do i=i1_t,i2_t
3563 j1 = jindx1(i)
3564 j2 = jindx2(i)
3565 i1 = iindx1(i)
3566 i2 = iindx2(i)
3567 if(wrk(i) .eq. 0.0) then
3568 if(.not.lmask) then
3569 if (num_threads == 1) then
3570 write(6,*) ' FATAL ERROR: la2ga called'
3571 write(6,*) ' with lmask=true. But bad rslmsk'
3572 write(6,*) ' or slmask given.'
3573 endif
3574 call abort
3575 endif
3576 ifill(it) = ifill(it) + 1
3577 if(ifill(it) <= 2 ) then
3578 if (me == 0 .and. num_threads == 1) then
3579 write(6,*) 'i1,i2,j1,j2=',i1,i2,j1,j2
3580 write(6,*) 'rslmsk=',rslmsk(i1,j1),rslmsk(i1,j2),
3581 & rslmsk(i2,j1),rslmsk(i2,j2)
3582! write(6,*) 'i,j=',i,j,' slmask(i)=',slmask(i)
3583 write(6,*) 'i=',i,' slmask(i)=',slmask(i)
3584 &, ' outlon=',outlon(i),' outlat=',outlat(i)
3585 endif
3586 endif
3587! spiral around until matching mask is found.
3588 do nx=1,jmxin*imxin/2
3589 kxs=sqrt(4*nx-2.5)
3590 kxt=nx-int(kxs**2/4+1)
3591 select case(mod(kxs,4))
3592 case(1)
3593 ix=i1-kxs/4+kxt
3594 jx=j1-kxs/4
3595 case(2)
3596 ix=i1+1+kxs/4
3597 jx=j1-kxs/4+kxt
3598 case(3)
3599 ix=i1+1+kxs/4-kxt
3600 jx=j1+1+kxs/4
3601 case default
3602 ix=i1-kxs/4
3603 jx=j1+kxs/4-kxt
3604 end select
3605 if(jx.lt.1) then
3606 ix=ix+imxin/2
3607 jx=2-jx
3608 elseif(jx.gt.jmxin) then
3609 ix=ix+imxin/2
3610 jx=2*jmxin-jx
3611 endif
3612 ix=modulo(ix-1,imxin)+1
3613 if(slmask(i).eq.rslmsk(ix,jx)) then
3614 gauout(i) = regin(ix,jx)
3615 imxnx(it) = max(imxnx(it),nx)
3616 go to 71
3617 endif
3618 enddo
3619!
3620 if (num_threads == 1) then
3621 write(6,*) ' FATAL ERROR: no filling value'
3622 write(6,*) ' found in routine la2ga.'
3623! write(6,*) ' i ix jx slmask(i) rslmsk ',
3624! & i,ix,jx,slmask(i),rslmsk(ix,jx)
3625 endif
3626 call abort
3627!
3628 71 continue
3629 endif
3630!
3631 enddo
3632 endif
3633 enddo ! end of threaded loop ...................
3634!$omp end parallel do
3635!
3636 if(inttyp /= 1)then
3637 ifills = 0
3638 do it=1,num_threads
3639 ifills = ifills + ifill(it)
3640 enddo
3641
3642 if(ifills.gt.1) then
3643 if (me .eq. 0) then
3644 write(6,*) ' unable to interpolate. filled with nearest',
3645 & ' point value at ',ifills,' points'
3646! & ' point value at ',ifills,' points imxnx=',imxnx(:)
3647 endif
3648 endif
3649 deallocate (ifill)
3650 endif
3651!
3652! kmami = 1
3653! if (me == 0) call maxmin(gauout,len,kmami)
3654!
3655 return
3656 end subroutine la2ga
3657
3659 subroutine maxmin(f,imax,kmax)
3660 use machine , only : kind_io8,kind_io4
3661 implicit none
3662 integer i,iimin,iimax,kmax,imax,k
3663 real (kind=kind_io8) fmin,fmax
3664!
3665 real (kind=kind_io8) f(imax,kmax)
3666!
3667 do k=1,kmax
3668!
3669 fmax = f(1,k)
3670 fmin = f(1,k)
3671!
3672 do i=1,imax
3673 if(fmax.le.f(i,k)) then
3674 fmax = f(i,k)
3675 iimax = i
3676 endif
3677 if(fmin.ge.f(i,k)) then
3678 fmin = f(i,k)
3679 iimin = i
3680 endif
3681 enddo
3682!
3683! write(6,100) k,fmax,iimax,fmin,iimin
3684! 100 format(2x,'level=',i2,' max=',e11.4,' at i=',i7,
3685! & ' min=',e11.4,' at i=',i7)
3686!
3687 enddo
3688!
3689 return
3690 end
3691
3693 subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, &
3694 & aisanl, &
3695 & tg3anl,cvanl ,cvbanl,cvtanl, &
3696 & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, &
3697 & vetanl,sotanl,socanl,alfanl, & !socanl: soil color
3698 & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic
3699 & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs
3700 & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, &
3701 & aisclm, &
3702 & tg3clm,cvclm ,cvbclm,cvtclm, &
3703 & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, &
3704 & vetclm,sotclm,socclm,alfclm, & !socclm: soil color
3705 & sihclm,sicclm, & !cwu [+1l] add ()clm for sih, sic
3706 & vmnclm,vmxclm,slpclm,absclm, & !clu [+1l] add ()clm for vmn, vmx, slp, abs
3707 & len,lsoil)
3708 use machine , only : kind_io8,kind_io4
3709 implicit none
3710 integer i,j,len,lsoil
3711!
3712 real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), &
3713 & snoanl(len), &
3714 & zoranl(len),albanl(len,4),aisanl(len), &
3715 & tg3anl(len), &
3716 & cvanl(len),cvbanl(len),cvtanl(len), &
3717 & cnpanl(len), &
3718 & smcanl(len,lsoil),stcanl(len,lsoil), &
3719 & slianl(len),scvanl(len),veganl(len), &
3720 & vetanl(len),sotanl(len),socanl(len),alfanl(len,2) & !socanl:soil color
3721 &, sihanl(len),sicanl(len) &
3722 &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len)
3723 real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), &
3724 & snoclm(len), &
3725 & zorclm(len),albclm(len,4),aisclm(len), &
3726 & tg3clm(len), &
3727 & cvclm(len),cvbclm(len),cvtclm(len), &
3728 & cnpclm(len), &
3729 & smcclm(len,lsoil),stcclm(len,lsoil), &
3730 & sliclm(len),scvclm(len),vegclm(len), &
3731 & vetclm(len),sotclm(len),socclm(len),alfclm(len,2) & !socclm:soil color
3732 &, sihclm(len),sicclm(len) &
3733 &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len)
3734!
3735 do i=1,len
3736 tsfanl(i) = tsfclm(i) ! tsf at t
3737 tsfan2(i) = tsfcl2(i) ! tsf at t-deltsfc
3738 wetanl(i) = wetclm(i) ! soil wetness
3739 snoanl(i) = snoclm(i) ! snow
3740 scvanl(i) = scvclm(i) ! snow cover
3741 aisanl(i) = aisclm(i) ! seaice
3742 slianl(i) = sliclm(i) ! land/sea/snow mask
3743 zoranl(i) = zorclm(i) ! surface roughness
3744! plranl(i) = plrclm(i) ! maximum stomatal resistance
3745 tg3anl(i) = tg3clm(i) ! deep soil temperature
3746 cnpanl(i) = cnpclm(i) ! canopy water content
3747 veganl(i) = vegclm(i) ! vegetation cover
3748 vetanl(i) = vetclm(i) ! vegetation type
3749 sotanl(i) = sotclm(i) ! soil type
3750 socanl(i) = socclm(i) ! soil color
3751 cvanl(i) = cvclm(i) ! cv
3752 cvbanl(i) = cvbclm(i) ! cvb
3753 cvtanl(i) = cvtclm(i) ! cvt
3754!cwu [+4l] add sih, sic
3755 sihanl(i) = sihclm(i) ! sea ice thickness
3756 sicanl(i) = sicclm(i) ! sea ice concentration
3757!clu [+4l] add vmn, vmx, slp, abs
3758 vmnanl(i) = vmnclm(i) ! min vegetation cover
3759 vmxanl(i) = vmxclm(i) ! max vegetation cover
3760 slpanl(i) = slpclm(i) ! slope type
3761 absanl(i) = absclm(i) ! max snow albedo
3762 enddo
3763!
3764 do j=1,lsoil
3765 do i=1,len
3766 smcanl(i,j) = smcclm(i,j) ! layer soil wetness
3767 stcanl(i,j) = stcclm(i,j) ! soil temperature
3768 enddo
3769 enddo
3770 do j=1,4
3771 do i=1,len
3772 albanl(i,j) = albclm(i,j) ! albedo
3773 enddo
3774 enddo
3775 do j=1,2
3776 do i=1,len
3777 alfanl(i,j) = alfclm(i,j) ! vegetation fraction for albedo
3778 enddo
3779 enddo
3780!
3781 return
3782 end
3783
3785 subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, &
3786 & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, &
3787 & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, &
3788 & fnveta,fnsota,fnsoca, & !fnsoca: soil color
3789 & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs
3790 & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, &
3791 & tg3anl,cvanl ,cvbanl,cvtanl, &
3792 & smcanl,stcanl,slianl,scvanl,acnanl,veganl, &
3793 & vetanl,sotanl,socanl,alfanl,tsfan0, & !soil color
3794 & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs
3795 & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais,&
3796 & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, &
3797 & kprvet,kpdsot,kpdsoc,kpdalf, & !kpdsoc: soil color
3798 & kpdvmn,kpdvmx,kpdslp,kpdabs, & !clu [+1l] add kpd() for vmn, vmx, slp, abs
3799 & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & !cggg snow mods
3800 & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, &
3801 & irtvet,irtsot,irtsoc,irtalf & !irtsoc: soil color
3802 &, irtvmn,irtvmx,irtslp,irtabs & !clu [+1l] add irt() for vmn, vmx, slp, abs
3803 &, imsk, jmsk, slmskh, outlat, outlon &
3804 &, gaus, blno, blto, me, lanom)
3805 use machine , only : kind_io8,kind_io4
3806 implicit none
3807 logical lanom
3808 integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, &
3809 & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot,irtsoc, & !irtsoc:soil color
3810 & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy,&
3811 & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsoc,kpdsmc,& !kpdsoc: soil color
3812 & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j &
3813 &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs
3814 real (kind=kind_io8) blto,blno,fh
3815!
3816 real (kind=kind_io8) slmskl(len), slmskw(len)
3817 real (kind=kind_io8) slmskh(imsk,jmsk)
3818 real (kind=kind_io8) outlat(len), outlon(len)
3819 integer kpdalb(4), kpdalf(2)
3820!cggg snow mods start
3821 integer kpds(1000),kgds(1000),jpds(1000),jgds(1000)
3822 integer lugi, lskip, lgrib, ndata
3823!cggg snow mods end
3824!
3825 character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, &
3826 & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, &
3827 & fnveta,fnsota,fnsoca, & !fnsoca: soil color
3828 & fnvmna,fnvmxa,fnslpa,fnabsa
3829
3830 real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), &
3831 & zoranl(len), albanl(len,4), aisanl(len), &
3832 & tg3anl(len), acnanl(len), &
3833 & cvanl(len), cvbanl(len), cvtanl(len), &
3834 & slianl(len), scvanl(len), veganl(len), &
3835 & vetanl(len), sotanl(len), socanl(len),alfanl(len,2), & !socanl: soil color
3836 & smcanl(len,lsoil), stcanl(len,lsoil), &
3837 & tsfan0(len) &
3838 &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len)
3839!
3840 logical gaus
3841!
3842! tsf
3843!
3844 irttsf = 1
3845 if(fntsfa(1:8).ne.' ') then
3846 call fixrda(lugb,fntsfa,kpdtsf,slmskw,
3847 & iy,im,id,ih,fh,tsfanl,len,iret
3848 &, imsk, jmsk, slmskh, gaus,blno, blto
3849 &, outlat, outlon, me)
3850 irttsf = iret
3851 if(iret == 1) then
3852 write(6,*) 'FATAL ERROR: t surface analysis read error.'
3853 call abort
3854 elseif(iret == -1) then
3855 if (me == 0) then
3856 print *,'old t surface analysis provided, indicating proper'
3857 &, ' file name is given. no error suspected.'
3858 write(6,*) 'forecast guess will be used'
3859 endif
3860 else
3861 if (me == 0) print *,'t surface analysis provided.'
3862 endif
3863 else
3864 if (me == 0) then
3865! print *,'************************************************'
3866 print *,'no tsf analysis available. climatology used'
3867 endif
3868 endif
3869!
3870! tsf0
3871!
3872 if(fntsfa(1:8).ne.' ' .and. lanom) then
3873 call fixrda(lugb,fntsfa,kpdtsf,slmskw,
3874 & iy,im,id,ih,0.,tsfan0,len,iret
3875 &, imsk, jmsk, slmskh, gaus,blno, blto
3876 &, outlat, outlon, me)
3877 if(iret == 1) then
3878 write(6,*) 'FATAL ERROR: t surface at ft=0 analysis'
3879 write(6,*) 'read error.'
3880 call abort
3881 elseif(iret == -1) then
3882 if (me == 0) then
3883 write(6,*) 'FATAL ERROR: Could not find t surface'
3884 write(6,*) 'analysis at ft=0.'
3885 endif
3886 call abort
3887 else
3888 print *,'t surface analysis at ft=0 found.'
3889 endif
3890 else
3891 do i=1,len
3892 tsfan0(i) = -999.9
3893 enddo
3894 endif
3895!
3896! albedo
3897!
3898 irtalb = 0
3899 if(fnalba(1:8).ne.' ') then
3900 do kk = 1, 4
3901 call fixrda(lugb,fnalba,kpdalb(kk),slmskl,
3902 & iy,im,id,ih,fh,albanl(1,kk),len,iret
3903 &, imsk, jmsk, slmskh, gaus,blno, blto
3904 &, outlat, outlon, me)
3905 irtalb = iret
3906 if(iret == 1) then
3907 write(6,*) 'FATAL ERROR: albedo analysis read error.'
3908 call abort
3909 elseif(iret == -1) then
3910 if (me == 0) then
3911 print *,'old albedo analysis provided, indicating proper',
3912 & ' file name is given. no error suspected.'
3913 write(6,*) 'forecast guess will be used'
3914 endif
3915 else
3916 if (me == 0 .and. kk == 4)
3917 & print *,'albedo analysis provided.'
3918 endif
3919 enddo
3920 else
3921 if (me == 0) then
3922! print *,'************************************************'
3923 print *,'no albedo analysis available. climatology used'
3924 endif
3925 endif
3926!
3927! vegetation fraction for albedo
3928!
3929 irtalf = 0
3930 if(fnalba(1:8).ne.' ') then
3931 do kk = 1, 2
3932 call fixrda(lugb,fnalba,kpdalf(kk),slmskl,
3933 & iy,im,id,ih,fh,alfanl(1,kk),len,iret
3934 &, imsk, jmsk, slmskh, gaus,blno, blto
3935 &, outlat, outlon, me)
3936 irtalf = iret
3937 if(iret == 1) then
3938 write(6,*) 'FATAL ERROR: albedo analysis read error.'
3939 call abort
3940 elseif(iret == -1) then
3941 if (me == 0) then
3942 print *,'old albedo analysis provided, indicating proper',
3943 & ' file name is given. no error suspected.'
3944 write(6,*) 'forecast guess will be used'
3945 endif
3946 else
3947 if (me == 0 .and. kk == 4)
3948 & print *,'albedo analysis provided.'
3949 endif
3950 enddo
3951 else
3952 if (me == 0) then
3953! print *,'************************************************'
3954 print *,'no vegfalbedo analysis available. climatology used'
3955 endif
3956 endif
3957!
3958! soil wetness
3959!
3960 irtwet=0
3961 irtsmc=0
3962 if(fnweta(1:8).ne.' ') then
3963 call fixrda(lugb,fnweta,kpdwet,slmskl,
3964 & iy,im,id,ih,fh,wetanl,len,iret
3965 &, imsk, jmsk, slmskh, gaus,blno, blto
3966 &, outlat, outlon, me)
3967 irtwet=iret
3968 if(iret.eq.1) then
3969 write(6,*) 'FATAL ERROR: bucket wetness analysis read error.'
3970 call abort
3971 elseif(iret.eq.-1) then
3972 if (me .eq. 0) then
3973 print *,'old wetness analysis provided, indicating proper',
3974 & ' file name is given. no error suspected.'
3975 write(6,*) 'forecast guess will be used'
3976 endif
3977 else
3978 if (me .eq. 0) print *,'bucket wetness analysis provided.'
3979 endif
3980 elseif(fnsmca(1:8).ne.' ') then
3981 call fixrda(lugb,fnsmca,kpdsmc,slmskl,
3982 & iy,im,id,ih,fh,smcanl(1,1),len,iret
3983 &, imsk, jmsk, slmskh, gaus,blno, blto
3984 &, outlat, outlon, me)
3985 call fixrda(lugb,fnsmca,kpdsmc,slmskl,
3986 & iy,im,id,ih,fh,smcanl(1,2),len,iret
3987 &, imsk, jmsk, slmskh, gaus,blno, blto
3988 &, outlat, outlon, me)
3989 irtsmc=iret
3990 if(iret.eq.1) then
3991 write(6,*) 'FATAL ERROR: layer soil wetness analysis'
3992 write(6,*) 'read error.'
3993 call abort
3994 elseif(iret.eq.-1) then
3995 if (me .eq. 0) then
3996 print *,'old layer soil wetness analysis provided',
3997 & ' indicating proper file name is given.'
3998 print *,' no error suspected.'
3999 write(6,*) 'forecast guess will be used'
4000 endif
4001 else
4002 if (me .eq. 0) print *,'layer soil wetness analysis provided.'
4003 endif
4004 else
4005 if (me .eq. 0) then
4006! print *,'************************************************'
4007 print *,'no soil wetness analysis available. climatology used'
4008 endif
4009 endif
4010!
4011! read in snow depth/snow cover
4012!
4013 irtscv=0
4014 if(fnsnoa(1:8).ne.' ') then
4015 do i=1,len
4016 scvanl(i)=0.
4017 enddo
4018!cggg snow mods start
4019!cggg need to determine if the snow data is on the gaussian grid
4020!cggg or not. if gaussian, then data is a depth, not liq equiv
4021!cggg depth. if not gaussian, then data is from hua-lu's
4022!cggg program and is a liquid equiv. need to communicate
4023!cggg this to routine fixrda via the 3rd argument which is
4024!cggg the grib parameter id number.
4025 call baopenr(lugb,fnsnoa,iret)
4026 if (iret .ne. 0) then
4027 write(6,*) 'FATAL ERROR: in opening file ',trim(fnsnoa)
4028 print *,'FATAL ERROR: in opening file ',trim(fnsnoa)
4029 call abort
4030 endif
4031 lugi=0
4032 lskip=-1
4033 jpds=-1
4034 jgds=-1
4035 kpds=jpds
4036 call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata,
4037 & lskip,kpds,kgds,iret)
4038 close(lugb)
4039 if (iret .ne. 0) then
4040 write(6,*) ' FATAL ERROR: reading header'
4041 write(6,*) ' of file: ',trim(fnsnoa)
4042 print *,'FATAL ERROR: reading header of file: ',trim(fnsnoa)
4043 call abort
4044 endif
4045 if (kgds(1) == 4) then ! gaussian data is depth
4046 call fixrda(lugb,fnsnoa,kpdsnd,slmskl,
4047 & iy,im,id,ih,fh,snoanl,len,iret
4048 &, imsk, jmsk, slmskh, gaus,blno, blto
4049 &, outlat, outlon, me)
4050 snoanl = snoanl*100. ! convert from meters to liq. eq.
4051 ! depth in mm using 10:1 ratio
4052 else ! lat/lon data is liq equv. depth
4053 call fixrda(lugb,fnsnoa,kpdsno,slmskl,
4054 & iy,im,id,ih,fh,snoanl,len,iret
4055 &, imsk, jmsk, slmskh, gaus,blno, blto
4056 &, outlat, outlon, me)
4057 endif
4058!cggg snow mods end
4059 irtscv=iret
4060 if(iret.eq.1) then
4061 write(6,*) 'FATAL ERROR: snow depth analysis read error.'
4062 call abort
4063 elseif(iret.eq.-1) then
4064 if (me .eq. 0) then
4065 print *,'old snow depth analysis provided, indicating proper',
4066 & ' file name is given. no error suspected.'
4067 write(6,*) 'forecast guess will be used'
4068 endif
4069 else
4070 if (me .eq. 0) print *,'snow depth analysis provided.'
4071 endif
4072 irtsno=0
4073 elseif(fnscva(1:8).ne.' ') then
4074 do i=1,len
4075 snoanl(i) = 0.
4076 enddo
4077 call fixrda(lugb,fnscva,kpdscv,slmskl,
4078 & iy,im,id,ih,fh,scvanl,len,iret
4079 &, imsk, jmsk, slmskh, gaus,blno, blto
4080 &, outlat, outlon, me)
4081 irtsno=iret
4082 if(iret.eq.1) then
4083 write(6,*) 'FATAL ERROR: snow cover analysis read error.'
4084 call abort
4085 elseif(iret.eq.-1) then
4086 if (me .eq. 0) then
4087 print *,'old snow cover analysis provided, indicating proper',
4088 & ' file name is given. no error suspected.'
4089 write(6,*) 'forecast guess will be used'
4090 endif
4091 else
4092 if (me .eq. 0) print *,'snow cover analysis provided.'
4093 endif
4094 else
4095 if (me .eq. 0) then
4096! print *,'************************************************'
4097 print *,'no snow/snocov analysis available. climatology used'
4098 endif
4099 endif
4100!
4101! sea ice mask
4102!
4103 irtacn=0
4104 irtais=0
4105 if(fnacna(1:8).ne.' ') then
4106 call fixrda(lugb,fnacna,kpdacn,slmskw,
4107 & iy,im,id,ih,fh,acnanl,len,iret
4108 &, imsk, jmsk, slmskh, gaus,blno, blto
4109 &, outlat, outlon, me)
4110 irtacn=iret
4111 if(iret.eq.1) then
4112 write(6,*) 'FATAL ERROR: ice concentration'
4113 write(6,*) 'analysis read error.'
4114 call abort
4115 elseif(iret.eq.-1) then
4116 if (me .eq. 0) then
4117 print *,'old ice concentration analysis provided',
4118 & ' indicating proper file name is given'
4119 print *,' no error suspected.'
4120 write(6,*) 'forecast guess will be used'
4121 endif
4122 else
4123 if (me .eq. 0) print *,'ice concentration analysis provided.'
4124 endif
4125 elseif(fnaisa(1:8).ne.' ') then
4126 call fixrda(lugb,fnaisa,kpdais,slmskw,
4127 & iy,im,id,ih,fh,aisanl,len,iret
4128 &, imsk, jmsk, slmskh, gaus,blno, blto
4129 &, outlat, outlon, me)
4130 irtais=iret
4131 if(iret.eq.1) then
4132 write(6,*) 'FATAL ERROR: ice mask analysis read error.'
4133 call abort
4134 elseif(iret.eq.-1) then
4135 if (me .eq. 0) then
4136 print *,'old ice-mask analysis provided, indicating proper',
4137 & ' file name is given. no error suspected.'
4138 write(6,*) 'forecast guess will be used'
4139 endif
4140 else
4141 if (me .eq. 0) print *,'ice mask analysis provided.'
4142 endif
4143 else
4144 if (me .eq. 0) then
4145! print *,'************************************************'
4146 print *,'no sea-ice analysis available. climatology used'
4147 endif
4148 endif
4149!
4150! surface roughness
4151!
4152 irtzor=0
4153 if(fnzora(1:8).ne.' ') then
4154 call fixrda(lugb,fnzora,kpdzor,slmskl,
4155 & iy,im,id,ih,fh,zoranl,len,iret
4156 &, imsk, jmsk, slmskh, gaus,blno, blto
4157 &, outlat, outlon, me)
4158 irtzor=iret
4159 if(iret.eq.1) then
4160 write(6,*) 'FATAL ERROR: roughness analysis read error.'
4161 call abort
4162 elseif(iret.eq.-1) then
4163 if (me .eq. 0) then
4164 print *,'old roughness analysis provided, indicating proper',
4165 & ' file name is given. no error suspected.'
4166 write(6,*) 'forecast guess will be used'
4167 endif
4168 else
4169 if (me .eq. 0) print *,'roughness analysis provided.'
4170 endif
4171 else
4172 if (me .eq. 0) then
4173! print *,'************************************************'
4174 print *,'no srfc roughness analysis available. climatology used'
4175 endif
4176 endif
4177!
4178! deep soil temperature
4179!
4180 irttg3=0
4181 irtstc=0
4182 if(fntg3a(1:8).ne.' ') then
4183 call fixrda(lugb,fntg3a,kpdtg3,slmskl,
4184 & iy,im,id,ih,fh,tg3anl,len,iret
4185 &, imsk, jmsk, slmskh, gaus,blno, blto
4186 &, outlat, outlon, me)
4187 irttg3=iret
4188 if(iret.eq.1) then
4189 write(6,*) 'FATAL ERROR: deep soil tmp analysis read error.'
4190 call abort
4191 elseif(iret.eq.-1) then
4192 if (me .eq. 0) then
4193 print *,'old deep soil temp analysis provided',
4194 & ' indicating proper file name is given.'
4195 print *,' no error suspected.'
4196 write(6,*) 'forecast guess will be used'
4197 endif
4198 else
4199 if (me .eq. 0) print *,'deep soil tmp analysis provided.'
4200 endif
4201 elseif(fnstca(1:8).ne.' ') then
4202 call fixrda(lugb,fnstca,kpdstc,slmskl,
4203 & iy,im,id,ih,fh,stcanl(1,1),len,iret
4204 &, imsk, jmsk, slmskh, gaus,blno, blto
4205 &, outlat, outlon, me)
4206 call fixrda(lugb,fnstca,kpdstc,slmskl,
4207 & iy,im,id,ih,fh,stcanl(1,2),len,iret
4208 &, imsk, jmsk, slmskh, gaus,blno, blto
4209 &, outlat, outlon, me)
4210 irtstc=iret
4211 if(iret.eq.1) then
4212 write(6,*) 'FATAL ERROR: layer soil tmp analysis read error.'
4213 call abort
4214 elseif(iret.eq.-1) then
4215 if (me .eq. 0) then
4216 print *,'old deep soil temp analysis provided',
4217 & 'iindicating proper file name is given.'
4218 print *,' no error suspected.'
4219 write(6,*) 'forecast guess will be used'
4220 endif
4221 else
4222 if (me .eq. 0) print *,'layer soil tmp analysis provided.'
4223 endif
4224 else
4225 if (me .eq. 0) then
4226! print *,'************************************************'
4227 print *,'no deep soil temp analy available. climatology used'
4228 endif
4229 endif
4230!
4231! vegetation cover
4232!
4233 irtveg=0
4234 if(fnvega(1:8).ne.' ') then
4235 call fixrda(lugb,fnvega,kpdveg,slmskl,
4236 & iy,im,id,ih,fh,veganl,len,iret
4237 &, imsk, jmsk, slmskh, gaus,blno, blto
4238 &, outlat, outlon, me)
4239 irtveg=iret
4240 if(iret.eq.1) then
4241 write(6,*) 'FATAL ERROR: vegetation cover analysis'
4242 write(6,*) 'read error.'
4243 call abort
4244 elseif(iret.eq.-1) then
4245 if (me .eq. 0) then
4246 print *,'old vegetation cover analysis provided',
4247 & ' indicating proper file name is given.'
4248 print *,' no error suspected.'
4249 write(6,*) 'forecast guess will be used'
4250 endif
4251 else
4252 if (me .eq. 0) print *,'gegetation cover analysis provided.'
4253 endif
4254 else
4255 if (me .eq. 0) then
4256! print *,'************************************************'
4257 print *,'no vegetation cover anly available. climatology used'
4258 endif
4259 endif
4260!
4261! vegetation type
4262!
4263 irtvet=0
4264 if(fnveta(1:8).ne.' ') then
4265 call fixrda(lugb,fnveta,kpdvet,slmskl,
4266 & iy,im,id,ih,fh,vetanl,len,iret
4267 &, imsk, jmsk, slmskh, gaus,blno, blto
4268 &, outlat, outlon, me)
4269 irtvet=iret
4270 if(iret.eq.1) then
4271 write(6,*) 'FATAL ERROR: vegetation type analysis'
4272 write(6,*) 'read error.'
4273 call abort
4274 elseif(iret.eq.-1) then
4275 if (me .eq. 0) then
4276 print *,'old vegetation type analysis provided',
4277 & ' indicating proper file name is given.'
4278 print *,' no error suspected.'
4279 write(6,*) 'forecast guess will be used'
4280 endif
4281 else
4282 if (me .eq. 0) print *,'vegetation type analysis provided.'
4283 endif
4284 else
4285 if (me .eq. 0) then
4286! print *,'************************************************'
4287 print *,'no vegetation type anly available. climatology used'
4288 endif
4289 endif
4290!
4291! soil type
4292!
4293 irtsot=0
4294 if(fnsota(1:8).ne.' ') then
4295 call fixrda(lugb,fnsota,kpdsot,slmskl,
4296 & iy,im,id,ih,fh,sotanl,len,iret
4297 &, imsk, jmsk, slmskh, gaus,blno, blto
4298 &, outlat, outlon, me)
4299 irtsot=iret
4300 if(iret.eq.1) then
4301 write(6,*) 'FATAL ERROR: soil type analysis read error.'
4302 call abort
4303 elseif(iret.eq.-1) then
4304 if (me .eq. 0) then
4305 print *,'old soil type analysis provided',
4306 & ' indicating proper file name is given.'
4307 print *,' no error suspected.'
4308 write(6,*) 'forecast guess will be used'
4309 endif
4310 else
4311 if (me .eq. 0) print *,'soil type analysis provided.'
4312 endif
4313 else
4314 if (me .eq. 0) then
4315! print *,'************************************************'
4316 print *,'no soil type anly available. climatology used'
4317 endif
4318 endif
4319
4320!
4321! soil color
4322!
4323 irtsoc=0
4324 if(fnsoca(1:8).ne.' ') then
4325 call fixrda(lugb,fnsoca,kpdsoc,slmskl,
4326 & iy,im,id,ih,fh,socanl,len,iret
4327 &, imsk, jmsk, slmskh, gaus,blno, blto
4328 &, outlat, outlon, me)
4329 irtsoc=iret
4330 if(iret.eq.1) then
4331 write(6,*) 'FATAL ERROR: soil color analysis read error.'
4332 call abort
4333 elseif(iret.eq.-1) then
4334 if (me .eq. 0) then
4335 print *,'old soil color analysis provided',
4336 & ' indicating proper file name is given.'
4337 print *,' no error suspected.'
4338 write(6,*) 'forecast guess will be used'
4339 endif
4340 else
4341 if (me .eq. 0) print *,'soil color analysis provided.'
4342 endif
4343 else
4344 if (me .eq. 0) then
4345! print *,'************************************************'
4346 print *,'no soil color anly available. climatology used'
4347 endif
4348 endif
4349
4350!clu [+120l]--------------------------------------------------------------
4351!
4352! min vegetation cover
4353!
4354 irtvmn=0
4355 if(fnvmna(1:8).ne.' ') then
4356 call fixrda(lugb,fnvmna,kpdvmn,slmskl,
4357 & iy,im,id,ih,fh,vmnanl,len,iret
4358 &, imsk, jmsk, slmskh, gaus,blno, blto
4359 &, outlat, outlon, me)
4360 irtvmn=iret
4361 if(iret.eq.1) then
4362 write(6,*) 'FATAL ERROR: shdmin analysis read error.'
4363 call abort
4364 elseif(iret.eq.-1) then
4365 if (me .eq. 0) then
4366 print *,'old shdmin analysis provided',
4367 & ' indicating proper file name is given.'
4368 print *,' no error suspected.'
4369 write(6,*) 'forecast guess will be used'
4370 endif
4371 else
4372 if (me .eq. 0) print *,'shdmin analysis provided.'
4373 endif
4374 else
4375 if (me .eq. 0) then
4376! print *,'************************************************'
4377 print *,'no shdmin anly available. climatology used'
4378 endif
4379 endif
4380
4381!
4382! max vegetation cover
4383!
4384 irtvmx=0
4385 if(fnvmxa(1:8).ne.' ') then
4386 call fixrda(lugb,fnvmxa,kpdvmx,slmskl,
4387 & iy,im,id,ih,fh,vmxanl,len,iret
4388 &, imsk, jmsk, slmskh, gaus,blno, blto
4389 &, outlat, outlon, me)
4390 irtvmx=iret
4391 if(iret.eq.1) then
4392 write(6,*) 'FATAL ERROR: shdmax analysis read error.'
4393 call abort
4394 elseif(iret.eq.-1) then
4395 if (me .eq. 0) then
4396 print *,'old shdmax analysis provided',
4397 & ' indicating proper file name is given.'
4398 print *,' no error suspected.'
4399 write(6,*) 'forecast guess will be used'
4400 endif
4401 else
4402 if (me .eq. 0) print *,'shdmax analysis provided.'
4403 endif
4404 else
4405 if (me .eq. 0) then
4406! print *,'************************************************'
4407 print *,'no shdmax anly available. climatology used'
4408 endif
4409 endif
4410
4411!
4412! slope type
4413!
4414 irtslp=0
4415 if(fnslpa(1:8).ne.' ') then
4416 call fixrda(lugb,fnslpa,kpdslp,slmskl,
4417 & iy,im,id,ih,fh,slpanl,len,iret
4418 &, imsk, jmsk, slmskh, gaus,blno, blto
4419 &, outlat, outlon, me)
4420 irtslp=iret
4421 if(iret.eq.1) then
4422 write(6,*) 'FATAL ERROR: slope type analysis read error.'
4423 call abort
4424 elseif(iret.eq.-1) then
4425 if (me .eq. 0) then
4426 print *,'old slope type analysis provided',
4427 & ' indicating proper file name is given.'
4428 print *,' no error suspected.'
4429 write(6,*) 'forecast guess will be used'
4430 endif
4431 else
4432 if (me .eq. 0) print *,'slope type analysis provided.'
4433 endif
4434 else
4435 if (me .eq. 0) then
4436! print *,'************************************************'
4437 print *,'no slope type anly available. climatology used'
4438 endif
4439 endif
4440
4441!
4442! max snow albedo
4443!
4444 irtabs=0
4445 if(fnabsa(1:8).ne.' ') then
4446 call fixrda(lugb,fnabsa,kpdabs,slmskl,
4447 & iy,im,id,ih,fh,absanl,len,iret
4448 &, imsk, jmsk, slmskh, gaus,blno, blto
4449 &, outlat, outlon, me)
4450 irtabs=iret
4451 if(iret.eq.1) then
4452 write(6,*) 'FATAL ERROR: snoalb analysis read error.'
4453 call abort
4454 elseif(iret.eq.-1) then
4455 if (me .eq. 0) then
4456 print *,'old snoalb analysis provided',
4457 & ' indicating proper file name is given.'
4458 print *,' no error suspected.'
4459 write(6,*) 'forecast guess will be used'
4460 endif
4461 else
4462 if (me .eq. 0) print *,'snoalb analysis provided.'
4463 endif
4464 else
4465 if (me .eq. 0) then
4466! print *,'************************************************'
4467 print *,'no snoalb anly available. climatology used'
4468 endif
4469 endif
4470
4471!clu ----------------------------------------------------------------------
4472!
4473 return
4474 end
4475
4477 subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, &
4478 & tg3fcs,cvfcs ,cvbfcs,cvtfcs, &
4479 & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, &
4480 & vegfcs, vetfcs, sotfcs,socfcs, alffcs, & !socfcs: soil color
4481 & sihfcs,sicfcs, & !cwu [+1l] add ()fcs for sih, sic
4482 & vmnfcs,vmxfcs,slpfcs,absfcs, & !clu [+1l] add ()fcs for vmn, vmx, slp, abs
4483 & tsfanl,wetanl,snoanl,zoranl,albanl, &
4484 & tg3anl,cvanl ,cvbanl,cvtanl, &
4485 & cnpanl,smcanl,stcanl,slianl,aisanl, &
4486 & veganl, vetanl, sotanl,socanl, alfanl, & !soil color
4487 & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic
4488 & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs
4489 & len,lsoil)
4490!
4491 use machine , only : kind_io8,kind_io4
4492 implicit none
4493 integer i,j,len,lsoil
4494 real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), &
4495 & zorfcs(len),albfcs(len,4),aisfcs(len), &
4496 & tg3fcs(len), &
4497 & cvfcs(len),cvbfcs(len),cvtfcs(len), &
4498 & cnpfcs(len), &
4499 & smcfcs(len,lsoil),stcfcs(len,lsoil), &
4500 & slifcs(len),vegfcs(len), &
4501 & vetfcs(len),sotfcs(len),socfcs(len),alffcs(len,2) & !socfcs: soil color
4502 &, sihfcs(len),sicfcs(len) &
4503 &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len)
4504 real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), &
4505 & zoranl(len),albanl(len,4),aisanl(len), &
4506 & tg3anl(len), &
4507 & cvanl(len),cvbanl(len),cvtanl(len), &
4508 & cnpanl(len), &
4509 & smcanl(len,lsoil),stcanl(len,lsoil), &
4510 & slianl(len),veganl(len), &
4511 & vetanl(len),sotanl(len),socanl(len),alfanl(len,2) & !socanl:soil color
4512 &, sihanl(len),sicanl(len) &
4513 &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len)
4514!
4515 write(6,*) ' this is a dead start run, tsfc over land is', &
4516 & ' set as lowest sigma level temperture if given.'
4517 write(6,*) ' if not, set to climatological tsf over land is used'
4518!
4519!
4520 do i=1,len
4521 tsffcs(i) = tsfanl(i) ! tsf
4522 albfcs(i,1) = albanl(i,1) ! albedo
4523 albfcs(i,2) = albanl(i,2) ! albedo
4524 albfcs(i,3) = albanl(i,3) ! albedo
4525 albfcs(i,4) = albanl(i,4) ! albedo
4526 wetfcs(i) = wetanl(i) ! soil wetness
4527 snofcs(i) = snoanl(i) ! snow
4528 aisfcs(i) = aisanl(i) ! seaice
4529 slifcs(i) = slianl(i) ! land/sea/snow mask
4530 zorfcs(i) = zoranl(i) ! surface roughness
4531! plrfcs(i) = plranl(i) ! maximum stomatal resistance
4532 tg3fcs(i) = tg3anl(i) ! deep soil temperature
4533 cnpfcs(i) = cnpanl(i) ! canopy water content
4534 cvfcs(i) = cvanl(i) ! cv
4535 cvbfcs(i) = cvbanl(i) ! cvb
4536 cvtfcs(i) = cvtanl(i) ! cvt
4537 vegfcs(i) = veganl(i) ! vegetation cover
4538 vetfcs(i) = vetanl(i) ! vegetation type
4539 sotfcs(i) = sotanl(i) ! soil type
4540 socfcs(i) = socanl(i) ! soil color
4541 alffcs(i,1) = alfanl(i,1) ! vegetation fraction for albedo
4542 alffcs(i,2) = alfanl(i,2) ! vegetation fraction for albedo
4543!cwu [+2l] add sih, sic
4544 sihfcs(i) = sihanl(i) ! sea ice thickness
4545 sicfcs(i) = sicanl(i) ! sea ice concentration
4546!clu [+4l] add vmn, vmx, slp, abs
4547 vmnfcs(i) = vmnanl(i) ! min vegetation cover
4548 vmxfcs(i) = vmxanl(i) ! max vegetation cover
4549 slpfcs(i) = slpanl(i) ! slope type
4550 absfcs(i) = absanl(i) ! max snow albedo
4551 enddo
4552!
4553 do j=1,lsoil
4554 do i=1,len
4555 smcfcs(i,j) = smcanl(i,j) ! layer soil wetness
4556 stcfcs(i,j) = stcanl(i,j) ! soil temperature
4557 enddo
4558 enddo
4559!
4560 return
4561 end
4562
4564 subroutine bktges(smcfcs,stcfcs,len,lsoil)
4565!
4566 use machine , only : kind_io8,kind_io4
4567 implicit none
4568 integer i,j,len,lsoil,k
4569 real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil)
4570!
4571! note that smfcs comes in with the original unit (cm?) (not grib file)
4572!
4573 do i = 1, len
4574 smcfcs(i,1) = (smcfcs(i,1)/150.) * .37 + .1
4575 enddo
4576 do k = 2, lsoil
4577 do i = 1, len
4578 smcfcs(i,k) = smcfcs(i,1)
4579 enddo
4580 enddo
4581 if(lsoil.gt.2) then
4582 do k = 3, lsoil
4583 do i = 1, len
4584 stcfcs(i,k) = stcfcs(i,2)
4585 enddo
4586 enddo
4587 endif
4588!
4589 return
4590 end
4591
4593 subroutine rof01(aisfld, len, op, crit)
4594 use machine , only : kind_io8,kind_io4
4595 implicit none
4596 integer i,len
4597 real (kind=kind_io8) aisfld(len),crit
4598 character*2 op
4599!
4600 if(op == 'ge') then
4601 do i=1,len
4602 if(aisfld(i) >= crit) then
4603 aisfld(i) = 1.
4604 else
4605 aisfld(i) = 0.
4606 endif
4607 enddo
4608 elseif(op == 'gt') then
4609 do i=1,len
4610 if(aisfld(i) > crit) then
4611 aisfld(i) = 1.
4612 else
4613 aisfld(i) = 0.
4614 endif
4615 enddo
4616 elseif(op == 'le') then
4617 do i=1,len
4618 if(aisfld(i) <= crit) then
4619 aisfld(i) = 1.
4620 else
4621 aisfld(i) = 0.
4622 endif
4623 enddo
4624 elseif(op == 'lt') then
4625 do i=1,len
4626 if(aisfld(i) < crit) then
4627 aisfld(i) = 1.
4628 else
4629 aisfld(i) = 0.
4630 endif
4631 enddo
4632 else
4633 write(6,*) ' FATAL ERROR: illegal operator'
4634 write(6,*) ' in rof01. op=',op
4635 call abort
4636 endif
4637!
4638 return
4639 end
4640
4642 subroutine rof01_len(aisfld, len, op, crit)
4643 use machine , only : kind_io8,kind_io4
4644 implicit none
4645 integer i,len
4646 real (kind=kind_io8), intent(in) :: crit(len)
4647 real (kind=kind_io8) aisfld(len)
4648 character*2 op
4649!
4650 if(op == 'ge') then
4651 do i=1,len
4652 if(aisfld(i) >= crit(i)) then
4653 aisfld(i) = 1.
4654 else
4655 aisfld(i) = 0.
4656 endif
4657 enddo
4658 elseif(op == 'gt') then
4659 do i=1,len
4660 if(aisfld(i) > crit(i)) then
4661 aisfld(i) = 1.
4662 else
4663 aisfld(i) = 0.
4664 endif
4665 enddo
4666 elseif(op == 'le') then
4667 do i=1,len
4668 if(aisfld(i) <= crit(i)) then
4669 aisfld(i) = 1.
4670 else
4671 aisfld(i) = 0.
4672 endif
4673 enddo
4674 elseif(op == 'lt') then
4675 do i=1,len
4676 if(aisfld(i) < crit(i)) then
4677 aisfld(i) = 1.
4678 else
4679 aisfld(i) = 0.
4680 endif
4681 enddo
4682 else
4683 write(6,*) ' FATAL ERROR: illegal operator'
4684 write(6,*) ' in rof01_len. op=',op
4685 call abort
4686 endif
4687!
4688 return
4689 end
4690
4691 subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse)
4692!
4693 use machine , only : kind_io8,kind_io4
4694 implicit none
4695 integer i,len
4696 real (kind=kind_io8) rlapse,umask
4697 real (kind=kind_io8) tsfc(len), orog(len), slmask(len)
4698!
4699 do i=1,len
4700 if(slmask(i).eq.umask) then
4701 tsfc(i) = tsfc(i) - orog(i)*rlapse
4702 endif
4703 enddo
4704 return
4705 end
4706
4709 subroutine snodpth(scvanl,slianl,tsfanl,snoclm, &
4710 & glacir,snwmax,snwmin,landice,len,snoanl, me)
4711 use machine , only : kind_io8,kind_io4
4712 implicit none
4713 integer i,me,len
4714 logical, intent(in) :: landice
4715 real (kind=kind_io8) sno,snwmax,snwmin
4716!
4717 real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), &
4718 & snoclm(len), snoanl(len), glacir(len)
4719!
4720 if (me .eq. 0) write(6,*) 'snodpth'
4721!
4722! use surface temperature to get snow depth estimate
4723!
4724 do i=1,len
4725 sno = 0.0
4726!
4727! over land
4728!
4729 if(slianl(i).eq.1.) then
4730 if(scvanl(i).eq.1.0) then
4731 if(tsfanl(i).lt.243.0) then
4732 sno = snwmax
4733 elseif(tsfanl(i).lt.273.0) then
4734 sno = snwmin+(snwmax-snwmin)*(273.0-tsfanl(i))/30.0
4735 else
4736 sno = snwmin
4737 endif
4738 endif
4739!
4740! if glacial points has snow in climatology, set sno to snomax
4741!
4742 if (.not.landice) then
4743 if(glacir(i).eq.1.0) then
4744 sno = snoclm(i)
4745 if(sno.eq.0.) sno=snwmax
4746 endif
4747 endif
4748 endif
4749!
4750! over sea ice
4751!
4752! snow over sea ice is cycled as of 01/01/94.....hua-lu pan
4753!
4754 if(slianl(i).eq.2.0) then
4755 sno=snoclm(i)
4756 if(sno.eq.0.) sno=snwmax
4757 endif
4758!
4759 snoanl(i) = sno
4760 enddo
4761 return
4762 end subroutine snodpth
4763
4766 subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, &
4767 & slmskl,slmskw,sihfcs,sicfcs, &
4768 & vmnfcs,vmxfcs,slpfcs,absfcs, &
4769 & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, &
4770 & cvfcs ,cvbfcs,cvtfcs, &
4771 & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, &
4772 & vetfcs,sotfcs,socfcs,alffcs, & !socfcs:soil color
4773 & sihanl,sicanl, &
4774 & vmnanl,vmxanl,slpanl,absanl, &
4775 & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl,&
4776 & cvanl ,cvbanl,cvtanl, &
4777 & cnpanl,smcanl,stcanl,slianl,veganl, &
4778 & vetanl,sotanl,socanl,alfanl, & !socanl:soil color
4779 & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, &
4780 & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, &
4781 & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, &
4782 & csocl,csocs, & !csocl,csocs:soil color
4783 & calfl,calfs, &
4784 & csihl,csihs,csicl,csics, &
4785 & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, &
4786 & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, &
4787 & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, &
4788 & irtvmn,irtvmx,irtslp,irtabs, &
4789 & irtvet,irtsot,irtsoc,irtalf, landice, me)
4790 use machine , only : kind_io8,kind_io4
4793 implicit none
4794 integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, &
4795 & irttg3,irtstc,irtalf,me,irtsot,irtsoc,irtveg,irtvet, irtzor, & !irtsoc:soil color
4796 & irtalb,irtsno,irttsf,irtwet,j &
4797 &, irtvmn,irtvmx,irtslp,irtabs
4798 logical, intent(in) :: landice
4799 real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rsocs, & !rsocs:soil color
4800 & rcnp,rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, &
4801 & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl,rsocl, &
4802 & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, &
4803 & qcnp,qcvb,qsots,qsocs,qcv,qaisl,qsnol,qalfl, &
4804 & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qsocl,qvegl, &
4805 & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, &
4806 & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, &
4807 & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, &
4808 & csocl,csocs, & !csocl,csocs:soil color
4809 & cvets,calfs,deltsfc, &
4810 & csihl,csihs,csicl,csics, &
4811 & rsihl,rsihs,rsicl,rsics, &
4812 & qsihl,qsihs,qsicl,qsics &
4813 &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps &
4814 &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs &
4815 &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns &
4816 &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss
4817!
4818 real (kind=kind_io8) slmskl(len), slmskw(len)
4819 real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), &
4820 & zorfcs(len), albfcs(len,4), aisfcs(len), &
4821 & cvfcs(len), cvbfcs(len), cvtfcs(len), &
4822 & cnpfcs(len), &
4823 & smcfcs(len,lsoil),stcfcs(len,lsoil), &
4824 & slifcs(len), vegfcs(len), &
4825 & vetfcs(len), sotfcs(len),socfcs(len), alffcs(len,2) & !socfcs:soil color
4826 &, sihfcs(len), sicfcs(len) &
4827 &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len)
4828 real (kind=kind_io8) tsfanl(len),tsfan2(len), &
4829 & wetanl(len),snoanl(len), &
4830 & zoranl(len), albanl(len,4), aisanl(len), &
4831 & cvanl(len), cvbanl(len), cvtanl(len), &
4832 & cnpanl(len), &
4833 & smcanl(len,lsoil),stcanl(len,lsoil), &
4834 & slianl(len), veganl(len), &
4835 & vetanl(len), sotanl(len),socanl(len), alfanl(len,2) & !socanl:soil color
4836 &, sihanl(len),sicanl(len) &
4837 &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len)
4838!
4839 real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), &
4840 & cstcl(lsoil), cstcs(lsoil)
4841 real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), &
4842 & rstcl(lsoil), rstcs(lsoil)
4843 real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), &
4844 & qstcl(lsoil), qstcs(lsoil)
4845 logical first
4846 data first /.true./
4847 save first
4848!
4849 integer len_thread_m, i1_t, i2_t, it
4850!
4851 if (first) then
4852 first = .false.
4853 endif
4854!
4855! coeeficients of blending forecast and interpolated clim
4856! (or analyzed) fields over sea or land(l) (not for clouds)
4857! 1.0 = use of forecast
4858! 0.0 = replace with interpolated analysis
4859!
4860! merging coefficients are defined by parameter statement in calling program
4861! and therefore they should not be modified in this program.
4862!
4863 rtsfl = ctsfl
4864 ralbl = calbl
4865 ralfl = calfl
4866 raisl = caisl
4867 rsnol = csnol
4868!clu rsmcl = csmcl
4869 rzorl = czorl
4870 rvegl = cvegl
4871 rvetl = cvetl
4872 rsotl = csotl
4873 rsocl = csocl !soil color
4874 rsihl = csihl
4875 rsicl = csicl
4876 rvmnl = cvmnl
4877 rvmxl = cvmxl
4878 rslpl = cslpl
4879 rabsl = cabsl
4880!
4881 rtsfs = ctsfs
4882 ralbs = calbs
4883 ralfs = calfs
4884 raiss = caiss
4885 rsnos = csnos
4886! rsmcs = csmcs
4887 rzors = czors
4888 rvegs = cvegs
4889 rvets = cvets
4890 rsots = csots
4891 rsocs = csocs !soil color
4892 rsihs = csihs
4893 rsics = csics
4894 rvmns = cvmns
4895 rvmxs = cvmxs
4896 rslps = cslps
4897 rabss = cabss
4898!
4899 rcv = ccv
4900 rcvb = ccvb
4901 rcvt = ccvt
4902 rcnp = ccnp
4903!
4904 do k=1,lsoil
4905 rsmcl(k) = csmcl(k)
4906 rsmcs(k) = csmcs(k)
4907 rstcl(k) = cstcl(k)
4908 rstcs(k) = cstcs(k)
4909 enddo
4910 if (fh-deltsfc < -0.001 .and. irttsf == 1) then
4911 rtsfs = 1.0
4912 rtsfl = 1.0
4913! do k=1,lsoil
4914! rsmcl(k) = 1.0
4915! rsmcs(k) = 1.0
4916! rstcl(k) = 1.0
4917! rstcs(k) = 1.0
4918! enddo
4919 endif
4920!
4921! if analysis file name is given but no matching analysis date found,
4922! use guess (these are flagged by irt???=1).
4923!
4924 if(irttsf == -1) then
4925 rtsfl = 1.
4926 rtsfs = 1.
4927 endif
4928 if(irtalb == -1) then
4929 ralbl = 1.
4930 ralbs = 1.
4931 ralfl = 1.
4932 ralfs = 1.
4933 endif
4934 if(irtais == -1) then
4935 raisl = 1.
4936 raiss = 1.
4937 endif
4938 if(irtsno == -1 .or. irtscv == -1) then
4939 rsnol = 1.
4940 rsnos = 1.
4941 endif
4942 if(irtsmc == -1 .or. irtwet == -1) then
4943! rsmcl = 1.
4944! rsmcs = 1.
4945 do k=1,lsoil
4946 rsmcl(k) = 1.
4947 rsmcs(k) = 1.
4948 enddo
4949 endif
4950 if(irtstc.eq.-1) then
4951 do k=1,lsoil
4952 rstcl(k) = 1.
4953 rstcs(k) = 1.
4954 enddo
4955 endif
4956 if(irtzor == -1) then
4957 rzorl = 1.
4958 rzors = 1.
4959 endif
4960 if(irtveg == -1) then
4961 rvegl = 1.
4962 rvegs = 1.
4963 endif
4964 if(irtvet.eq.-1) then
4965 rvetl = 1.
4966 rvets = 1.
4967 endif
4968 if(irtsot == -1) then
4969 rsotl = 1.
4970 rsots = 1.
4971 endif
4972
4973 if(irtsoc == -1) then !soil color
4974 rsocl = 1.
4975 rsocs = 1.
4976 endif
4977
4978 if(irtacn == -1) then
4979 rsicl = 1.
4980 rsics = 1.
4981 endif
4982 if(irtvmn == -1) then
4983 rvmnl = 1.
4984 rvmns = 1.
4985 endif
4986 if(irtvmx == -1) then
4987 rvmxl = 1.
4988 rvmxs = 1.
4989 endif
4990 if(irtslp == -1) then
4991 rslpl = 1.
4992 rslps = 1.
4993 endif
4994 if(irtabs == -1) then
4995 rabsl = 1.
4996 rabss = 1.
4997 endif
4998!
4999 if(raiss == 1. .or. irtacn == -1) then
5000 if (me == 0) print *,'use forecast land-sea-ice mask'
5001 do i = 1, len
5002 aisanl(i) = aisfcs(i)
5003 slianl(i) = slifcs(i)
5004 enddo
5005 endif
5006!
5007 if (me == 0) then
5008 write(6,100) rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl
5009 100 format('rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl=',10f7.3)
5010 write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics
5011 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics=',11f7.3)
5012
5013 write(6,102) rsocl,rsocs
5014 102 format('rsoc1, rsocs =',10f7.3)
5015
5016 endif
5017!
5018 qtsfl = 1. - rtsfl
5019 qalbl = 1. - ralbl
5020 qalfl = 1. - ralfl
5021 qaisl = 1. - raisl
5022 qsnol = 1. - rsnol
5023! qsmcl = 1. - rsmcl
5024 qzorl = 1. - rzorl
5025 qvegl = 1. - rvegl
5026 qvetl = 1. - rvetl
5027 qsotl = 1. - rsotl
5028 qsocl = 1. - rsocl !soil color
5029
5030 qsihl = 1. - rsihl
5031 qsicl = 1. - rsicl
5032 qvmnl = 1. - rvmnl
5033 qvmxl = 1. - rvmxl
5034 qslpl = 1. - rslpl
5035 qabsl = 1. - rabsl
5036!
5037 qtsfs = 1. - rtsfs
5038 qalbs = 1. - ralbs
5039 qalfs = 1. - ralfs
5040 qaiss = 1. - raiss
5041 qsnos = 1. - rsnos
5042! qsmcs = 1. - rsmcs
5043 qzors = 1. - rzors
5044 qvegs = 1. - rvegs
5045 qvets = 1. - rvets
5046 qsots = 1. - rsots
5047 qsocs = 1. - rsocs
5048
5049 qsihs = 1. - rsihs
5050 qsics = 1. - rsics
5051 qvmns = 1. - rvmns
5052 qvmxs = 1. - rvmxs
5053 qslps = 1. - rslps
5054 qabss = 1. - rabss
5055!
5056 qcv = 1. - rcv
5057 qcvb = 1. - rcvb
5058 qcvt = 1. - rcvt
5059 qcnp = 1. - rcnp
5060!
5061 do k=1,lsoil
5062 qsmcl(k) = 1. - rsmcl(k)
5063 qsmcs(k) = 1. - rsmcs(k)
5064 qstcl(k) = 1. - rstcl(k)
5065 qstcs(k) = 1. - rstcs(k)
5066 enddo
5067!
5068! merging
5069!
5070 if(me .eq. 0) then
5071 print *, 'dbgx-- csmcl:', (csmcl(k),k=1,lsoil)
5072 print *, 'dbgx-- rsmcl:', (rsmcl(k),k=1,lsoil)
5073 print *, 'dbgx-- csnol, csnos:',csnol,csnos
5074 print *, 'dbgx-- rsnol, rsnos:',rsnol,rsnos
5075 endif
5076!
5077 len_thread_m = (len+num_threads-1) / num_threads
5078
5079!$omp parallel do private(i1_t,i2_t,it,i)
5080 do it=1,num_threads ! start of threaded loop ...................
5081 i1_t = (it-1)*len_thread_m+1
5082 i2_t = min(i1_t+len_thread_m-1,len)
5083 do i=i1_t,i2_t
5084 if(slianl(i) == zero) then
5085 vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets
5086 sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots
5087 socanl(i) = socfcs(i)*rsocs + socanl(i)*qsocs
5088 else
5089 vetanl(i) = vetfcs(i)*rvetl + vetanl(i)*qvetl
5090 sotanl(i) = sotfcs(i)*rsotl + sotanl(i)*qsotl
5091 socanl(i) = socfcs(i)*rsocl + socanl(i)*qsocl
5092 endif
5093 enddo
5094 enddo
5095!$omp end parallel do
5096!
5097!$omp parallel do private(i1_t,i2_t,it,i,k)
5098!
5099 do it=1,num_threads ! start of threaded loop ...................
5100 i1_t = (it-1)*len_thread_m+1
5101 i2_t = min(i1_t+len_thread_m-1,len)
5102!
5103 do i=i1_t,i2_t
5104 if(slianl(i) == zero) then
5105! if(slmskw(i) == zero) then
5106!.... tsffc2 is the previous anomaly + today's climatology
5107! tsffc2 = (tsffcs(i)-tsfan2(i))+tsfanl(i)
5108! tsfanl(i) = tsffc2 *rtsfs+tsfanl(i)*qtsfs
5109!
5110 tsfanl(i) = tsffcs(i)*rtsfs + tsfanl(i)*qtsfs
5111! albanl(i) = albfcs(i)*ralbs + albanl(i)*qalbs
5112 aisanl(i) = aisfcs(i)*raiss + aisanl(i)*qaiss
5113 snoanl(i) = snofcs(i)*rsnos + snoanl(i)*qsnos
5114
5115 zoranl(i) = zorfcs(i)*rzors + zoranl(i)*qzors
5116 veganl(i) = vegfcs(i)*rvegs + veganl(i)*qvegs
5117 sihanl(i) = sihfcs(i)*rsihs + sihanl(i)*qsihs
5118 sicanl(i) = sicfcs(i)*rsics + sicanl(i)*qsics
5119 vmnanl(i) = vmnfcs(i)*rvmns + vmnanl(i)*qvmns
5120 vmxanl(i) = vmxfcs(i)*rvmxs + vmxanl(i)*qvmxs
5121 slpanl(i) = slpfcs(i)*rslps + slpanl(i)*qslps
5122 absanl(i) = absfcs(i)*rabss + absanl(i)*qabss
5123 endif
5124 if(slmskl(i) == one .or. slianl(i) > zero) then
5125 tsfanl(i) = tsffcs(i)*rtsfl + tsfanl(i)*qtsfl
5126! albanl(i) = albfcs(i)*ralbl + albanl(i)*qalbl
5127 aisanl(i) = aisfcs(i)*raisl + aisanl(i)*qaisl
5128 if(rsnol.ge.0)then
5129 snoanl(i) = snofcs(i)*rsnol + snoanl(i)*qsnol
5130 else ! envelope method
5131 if(snoanl(i).ne.0)then
5132 snoanl(i) = max(-snoanl(i)/rsnol,
5133 & min(-snoanl(i)*rsnol, snofcs(i)))
5134 endif
5135 endif
5136 zoranl(i) = zorfcs(i)*rzorl + zoranl(i)*qzorl
5137 veganl(i) = vegfcs(i)*rvegl + veganl(i)*qvegl
5138 vmnanl(i) = vmnfcs(i)*rvmnl + vmnanl(i)*qvmnl
5139 vmxanl(i) = vmxfcs(i)*rvmxl + vmxanl(i)*qvmxl
5140 slpanl(i) = slpfcs(i)*rslpl + slpanl(i)*qslpl
5141 absanl(i) = absfcs(i)*rabsl + absanl(i)*qabsl
5142 sihanl(i) = sihfcs(i)*rsihl + sihanl(i)*qsihl
5143 sicanl(i) = sicfcs(i)*rsicl + sicanl(i)*qsicl
5144 endif
5145
5146 cnpanl(i) = cnpfcs(i)*rcnp + cnpanl(i)*qcnp
5147!
5148! snow over sea ice is cycled
5149!
5150 if (nint(slianl(i)) == 2) then
5151 snoanl(i) = snofcs(i)
5152 endif
5153!
5154 enddo
5155
5156! at landice points, set the soil type, color,slope type and
5157! greenness fields to flag values.
5158
5159 if (landice) then
5160 do i=i1_t,i2_t
5161 if (nint(slianl(i)) == 1) then
5162 if (nint(vetanl(i)) == veg_type_landice) then
5163 sotanl(i) = soil_type_landice
5164 socanl(i) = soil_color_landice
5165 veganl(i) = 0.0
5166 slpanl(i) = 9.0
5167 vmnanl(i) = 0.0
5168 vmxanl(i) = 0.0
5169 endif
5170 end if ! if land
5171 enddo
5172 endif
5173
5174 do i=i1_t,i2_t
5175 cvanl(i) = cvfcs(i)*rcv + cvanl(i)*qcv
5176 cvbanl(i) = cvbfcs(i)*rcvb + cvbanl(i)*qcvb
5177 cvtanl(i) = cvtfcs(i)*rcvt + cvtanl(i)*qcvt
5178 enddo
5179!
5180 do k = 1, 4
5181 do i=i1_t,i2_t
5182 if (nint(slianl(i)) == 0) then
5183 albanl(i,k) = albfcs(i,k)*ralbs + albanl(i,k)*qalbs
5184 else
5185 albanl(i,k) = albfcs(i,k)*ralbl + albanl(i,k)*qalbl
5186 endif
5187 enddo
5188 enddo
5189!
5190 do k = 1, 2
5191 do i=i1_t,i2_t
5192 if (nint(slianl(i)) == 0) then
5193 alfanl(i,k) = alffcs(i,k)*ralfs + alfanl(i,k)*qalfs
5194 else
5195 alfanl(i,k) = alffcs(i,k)*ralfl + alfanl(i,k)*qalfl
5196 endif
5197 enddo
5198 enddo
5199!
5200 do k = 1, lsoil
5201 do i=i1_t,i2_t
5202 if (nint(slianl(i)) == 0) then
5203 smcanl(i,k) = smcfcs(i,k)*rsmcs(k) + smcanl(i,k)*qsmcs(k)
5204 stcanl(i,k) = stcfcs(i,k)*rstcs(k) + stcanl(i,k)*qstcs(k)
5205 else
5206! soil moisture not used at landice points, so
5207! don't bother merging it. also, for now don't allow nudging
5208! to raise subsurface temperature above freezing.
5209 stcanl(i,k) = stcfcs(i,k)*rstcl(k) + stcanl(i,k)*qstcl(k)
5210 if (landice .and. slianl(i) == 1.0 .and.
5211 & nint(vetanl(i)) == veg_type_landice) then
5212 smcanl(i,k) = 1.0 ! use value as flag
5213 stcanl(i,k) = min(stcanl(i,k), 273.15)
5214 else
5215 smcanl(i,k) = smcfcs(i,k)*rsmcl(k) + smcanl(i,k)*qsmcl(k)
5216 end if
5217 endif
5218 enddo
5219 enddo
5220!
5221 enddo ! end of threaded loop ...................
5222!$omp end parallel do
5223 return
5224 end subroutine merge
5225
5227 subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, &
5228 & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl
5229 & albanl,snoanl,zoranl,smcanl,stcanl, &
5230 & albsea,snosea,zorsea,smcsea,smcice, &
5231 & tsfmin,tsfice,albice,zorice,tgice, &
5232 & rla,rlo,me)
5233!
5234 use machine , only : kind_io8,kind_io4
5235 implicit none
5236 real (kind=kind_io8), parameter :: one=1.0
5237 real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, &
5238 & smcice,tsfmin,zorsea,smcsea
5239!cwu [+1l] add sicnew,sihnew
5240 &, sicnew,sihnew
5241 integer i,me,kount1,kount2,k,len,lsoil
5242 real (kind=kind_io8) slianl(len), slifcs(len),
5243 & tsffcs(len),tsfanl(len)
5244 real (kind=kind_io8) albanl(len,4), snoanl(len), zoranl(len)
5245 real (kind=kind_io8) smcanl(len,lsoil), stcanl(len,lsoil)
5246!cwu [+1l] add sihanl & sicanl
5247 real (kind=kind_io8) sihanl(len), sicanl(len)
5248!
5249 real (kind=kind_io8) rla(len), rlo(len)
5250!
5251 if (me .eq. 0) write(6,*) 'newice'
5252!
5253 kount1 = 0
5254 kount2 = 0
5255 do i=1,len
5256 if (nint(slifcs(i)) /= nint(slianl(i))) then
5257 if (nint(slifcs(i)) == 1 .or. nint(slianl(i)) == 1) then
5258 print *,'FATAL ERROR: inconsistency in slifcs or slianl.'
5259 print 910,rla(i),rlo(i),slifcs(i),slianl(i),
5260 & tsffcs(i),tsfanl(i)
5261 910 format(2x,'at lat=',f5.1,' lon=',f5.1,' slifcs=',f4.1,
5262 & ' slimsk=',f4.1,' tsffcs=',f5.1,' set to tsfanl=',f5.1)
5263 call abort
5264 endif
5265!
5266! interpolated climatology indicates melted sea ice
5267!
5268 if (nint(slianl(i)) == 0 .and. nint(slifcs(i)) == 2) then
5269 tsfanl(i) = tsfmin
5270 albanl(i,1) = albsea
5271 albanl(i,2) = albsea
5272 albanl(i,3) = albsea
5273 albanl(i,4) = albsea
5274 snoanl(i) = snosea
5275 zoranl(i) = zorsea
5276 do k = 1, lsoil
5277 smcanl(i,k) = smcsea
5278!cwu [+1l] set stcanl to tgice (over sea-ice)
5279 stcanl(i,k) = tgice
5280 enddo
5281!cwu [+2l] set siganl and sicanl
5282 sihanl(i) = 0.
5283 sicanl(i) = 0.
5284 kount1 = kount1 + 1
5285 endif
5286!
5287! interplated climatoloyg/analysis indicates new sea ice
5288!
5289 if (nint(slianl(i)) == 2 .and. nint(slifcs(i)) == 0) then
5290 tsfanl(i) = tsfice
5291 albanl(i,1) = albice
5292 albanl(i,2) = albice
5293 albanl(i,3) = albice
5294 albanl(i,4) = albice
5295 snoanl(i) = 0.
5296 zoranl(i) = zorice
5297 do k = 1, lsoil
5298 smcanl(i,k) = smcice
5299 stcanl(i,k) = tgice
5300 enddo
5301!cwu [+2l] add sihanl & sicanl
5302 sihanl(i) = sihnew
5303 sicanl(i) = min(one, max(sicnew,sicanl(i)))
5304 kount2 = kount2 + 1
5305 endif
5306 endif
5307 enddo
5308!
5309 if (me == 0) then
5310 if (kount1 > 0) then
5311 write(6,*) 'sea ice melted. tsf,alb,zor are filled',
5312 & ' at ',kount1,' points'
5313 endif
5314 if(kount2 > 0) then
5315 write(6,*) 'sea ice formed. tsf,alb,zor are filled',
5316 & ' at ',kount2,' points'
5317 endif
5318 endif
5319!
5320 return
5321 end
5322
5324 subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, &
5325 & landice,me)
5326 use machine , only : kind_io8,kind_io4
5327 implicit none
5328 integer kount,i,len,me
5329 logical, intent(in) :: landice
5330 real (kind=kind_io8) per,snoval
5331 real (kind=kind_io8) snoanl(len),slmask(len),
5332 & aisanl(len),glacir(len)
5333 if (me .eq. 0) then
5334 write(6,*) ' '
5335 write(6,*) 'qc of snow'
5336 endif
5337 if (.not.landice) then
5338 kount=0
5339 do i=1,len
5340 if(glacir(i).ne.0..and.snoanl(i).eq.0.) then
5341! if(glacir(i).ne.0..and.snoanl(i).lt.snoval*0.5) then
5342 snoanl(i) = snoval
5343 kount = kount + 1
5344 endif
5345 enddo
5346 per = float(kount) / float(len)*100.
5347 if(kount.gt.0) then
5348 if (me .eq. 0) then
5349 print *,'snow filled over glacier points at ',kount,
5350 & ' points (',per,'percent)'
5351 endif
5352 endif
5353 endif ! landice check
5354 kount = 0
5355 do i=1,len
5356 if(slmask(i).eq.0.and.aisanl(i).eq.0) then
5357 snoanl(i) = 0.
5358 kount = kount + 1
5359 endif
5360 enddo
5361 per = float(kount) / float(len)*100.
5362 if(kount.gt.0) then
5363 if (me .eq. 0) then
5364 print *,'snow set to zero over open sea at ',kount,
5365 & ' points (',per,'percent)'
5366 endif
5367 endif
5368 return
5369 end subroutine qcsnow
5370
5372 subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, &
5373 & rla,rlo,len,me)
5374 use machine , only : kind_io8,kind_io4
5375 implicit none
5376 integer kount1,kount,i,me,len
5377 real (kind=kind_io8) per,aicsea,aicice,sllnd
5378!
5379 real (kind=kind_io8) ais(len), glacir(len), &
5380 & amxice(len), slmask(len)
5381 real (kind=kind_io8) rla(len), rlo(len)
5382!
5383! check sea-ice cover mask against land-sea mask
5384!
5385 if (me == 0) write(6,*) 'qc of sea ice'
5386 kount = 0
5387 kount1 = 0
5388 do i=1,len
5389 if(ais(i).ne.aicice.and.ais(i).ne.aicsea) then
5390 print *,'FATAL ERROR: sea ice'
5391 print *,'mask not ',aicice,' or ',aicsea
5392 print *,'ais(i),aicice,aicsea,rla(i),rlo(i,=',
5393 & ais(i),aicice,aicsea,rla(i),rlo(i)
5394 call abort
5395 endif
5396 if(slmask(i).eq.0..and.glacir(i).eq.1..and.
5397! if(slmask(i).eq.0..and.glacir(i).eq.2..and.
5398 & ais(i).ne.1.) then
5399 kount1 = kount1 + 1
5400 ais(i) = 1.
5401 endif
5402 if(slmask(i).eq.sllnd.and.ais(i).eq.aicice) then
5403 kount = kount + 1
5404 ais(i) = aicsea
5405 endif
5406 enddo
5407! enddo
5408 per = float(kount) / float(len)*100.
5409 if(kount.gt.0) then
5410 if(me .eq. 0) then
5411 print *,' sea ice over land mask at ',kount,' points (',per,
5412 & 'percent)'
5413 endif
5414 endif
5415 per = float(kount1) / float(len)*100.
5416 if(kount1.gt.0) then
5417 if(me .eq. 0) then
5418 print *,' sea ice set over glacier points over ocean at ',
5419 & kount1,' points (',per,'percent)'
5420 endif
5421 endif
5422! kount=0
5423! do j=1,jdim
5424! do i=1,idim
5425! if(amxice(i,j).ne.0..and.ais(i,j).eq.0.) then
5426! ais(i,j)=0.
5427! kount=kount+1
5428! endif
5429! enddo
5430! enddo
5431! per=float(kount)/float(idim*jdim)*100.
5432! if(kount.gt.0) then
5433! print *,' sea ice exceeds maxice at ',kount,' points (',per,
5434! & 'percent)'
5435! endif
5436!
5437! remove isolated open ocean surrounded by sea ice and/or land
5438!
5439! remove isolated open ocean surrounded by sea ice and/or land
5440!
5441! ij = 0
5442! do j=1,jdim
5443! do i=1,idim
5444! ij = ij + 1
5445! ip = i + 1
5446! im = i - 1
5447! jp = j + 1
5448! jm = j - 1
5449! if(jp.gt.jdim) jp = jdim - 1
5450! if(jm.lt.1) jm = 2
5451! if(ip.gt.idim) ip = 1
5452! if(im.lt.1) im = idim
5453! if(slmask(i,j).eq.0..and.ais(i,j).eq.0.) then
5454! if((slmask(ip,jp).eq.1..or.ais(ip,jp).eq.1.).and.
5455! & (slmask(i ,jp).eq.1..or.ais(i ,jp).eq.1.).and.
5456! & (slmask(im,jp).eq.1..or.ais(im,jp).eq.1.).and.
5457! & (slmask(ip,j ).eq.1..or.ais(ip,j ).eq.1.).and.
5458! & (slmask(im,j ).eq.1..or.ais(im,j ).eq.1.).and.
5459! & (slmask(ip,jm).eq.1..or.ais(ip,jm).eq.1.).and.
5460! & (slmask(i ,jm).eq.1..or.ais(i ,jm).eq.1.).and.
5461! & (slmask(im,jm).eq.1..or.ais(im,jm).eq.1.)) then
5462! ais(i,j) = 1.
5463! write(6,*) ' isolated open sea point surrounded by',
5464! & ' sea ice or land modified to sea ice',
5465! & ' at lat=',rla(i,j),' lon=',rlo(i,j)
5466! endif
5467! endif
5468! enddo
5469! enddo
5470 return
5471 end
5472
5474 subroutine setlsi(slmask,aisfld,len,aicice,slifld)
5475!
5476 use machine , only : kind_io8,kind_io4
5477 implicit none
5478 integer i,len
5479 real (kind=kind_io8) aicice
5480 real (kind=kind_io8) slmask(len), slifld(len), aisfld(len)
5481!
5482! set surface condition indicator slimsk
5483!
5484 do i=1,len
5485 slifld(i) = slmask(i)
5486 if(aisfld(i) == aicice .and. slmask(i) == 0.0) &
5487 & slifld(i) = 2.0
5488 enddo
5489 return
5490 end
5491
5492 subroutine scale(fld,len,scl)
5493!
5494 use machine , only : kind_io8,kind_io4
5495 implicit none
5496 integer i,len
5497 real (kind=kind_io8) fld(len),scl
5498 do i=1,len
5499 fld(i) = fld(i) * scl
5500 enddo
5501 return
5502 end
5503
5505 subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, &
5506 & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, &
5507 & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, &
5508 & rla,rlo,len,mode,percrit,lgchek,me)
5509!
5510 use machine , only : kind_io8,kind_io4
5511 use sfccyc_module , only : num_threads
5512 implicit none
5513 integer, intent(in) :: len, mode, me
5514 real (kind=kind_io8), intent(in) :: fldimx,fldimn,fldjmx,fldomn, &
5515 & fldlmx,fldlmn,fldomx,fldjmn, &
5516 & fldsmx,fldsmn,epsfld,percrit &
5517 integer, parameter :: mmprt=2
5518!
5519 character(len=*) ttl
5520 logical iceflg(len)
5521 real (kind=kind_io8), dimension(len) :: fld, slimsk, sno, rla, rlo
5522 logical lgchek
5523!
5524 logical first
5525 real (kind=kind_io8) permax, per
5526 data first /.true./
5527 save first
5528!
5529 integer :: len_thread_m, i1_t, i2_t, it, &
5530 & kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,kminj, &
5531 & ij,nprt,kmaxs,kmins,i
5532 integer :: islimsk(len), iwk(len)
5533!
5534 if (first) then
5535 first = .false.
5536 endif
5537 do it=1,len
5538 islimsk(it) = nint(slimsk(it))
5539 enddo
5540!
5541! check against land-sea mask and ice cover mask
5542!
5543 if(me == 0) then
5544 print *,'performing qc of ',ttl,' mode=',mode,
5545 & '(0=count only, 1=replace)'
5546 endif
5547!
5548 len_thread_m = (len+num_threads-1) / num_threads
5549
5550 kmaxl = 0 ; kminl = 0 ; kmaxo = 0 ; kmino = 0
5551 kmaxi = 0 ; kmini = 0 ; kmaxj = 0 ; kminj = 0
5552 kmaxs = 0 ; kmins = 0
5553
5554!$omp parallel do private(i1_t,i2_t,it,i)
5555!$omp+private(nprt,ij,iwk)
5556!$omp+reduction(+:kmaxs,kmins,kmaxl,kminl,kmaxo)
5557!$omp+reduction(+:kmino,kmaxi,kmini,kmaxj,kminj)
5558!$omp+shared(mode,epsfld)
5559!$omp+shared(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn)
5560!$omp+shared(fld,islimsk,sno,rla,rlo)
5561 do it=1,num_threads ! start of threaded loop
5562 i1_t = (it-1)*len_thread_m+1
5563 i2_t = min(i1_t+len_thread_m-1,len)
5564!
5565!
5566!
5567! lower bound check over bare land
5568!
5569 if (fldlmn /= 999.0) then
5570 do i=i1_t,i2_t
5571 if(islimsk(i) == 1 .and. sno(i) <= 0.0 &
5572 & .and. fld(i) < fldlmn-epsfld) then
5573 kminl = kminl + 1
5574 iwk(kminl) = i
5575 endif
5576 enddo
5577 if(me == 0 .and. it == 1 .and. num_threads == 1) then
5578 nprt = min(mmprt,kminl)
5579 do i=1,nprt
5580 ij = iwk(i)
5581 print 8001,rla(ij),rlo(ij),fld(ij),fldlmn
5582 8001 format(' bare land min. check. lat=',f5.1, &
5583 & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6)
5584 enddo
5585 endif
5586 if (mode == 1) then
5587 do i=1,kminl
5588 fld(iwk(i)) = fldlmn
5589 enddo
5590 endif
5591 endif
5592!
5593! upper bound check over bare land
5594!
5595 if (fldlmx /= 999.0) then
5596 do i=i1_t,i2_t
5597 if(islimsk(i) == 1 .and. sno(i) <= 0.0 &
5598 & .and. fld(i) > fldlmx+epsfld) then
5599 kmaxl = kmaxl + 1
5600 iwk(kmaxl) = i
5601 endif
5602 enddo
5603 if(me == 0 . and. it == 1 .and. num_threads == 1) then
5604 nprt = min(mmprt,kmaxl)
5605 do i=1,nprt
5606 ij = iwk(i)
5607 print 8002,rla(ij),rlo(ij),fld(ij),fldlmx
5608 8002 format(' bare land max. check. lat=',f5.1, &
5609 & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6)
5610 enddo
5611 endif
5612 if (mode == 1) then
5613 do i=1,kmaxl
5614 fld(iwk(i)) = fldlmx
5615 enddo
5616 endif
5617 endif
5618!
5619! lower bound check over snow covered land
5620!
5621 if (fldsmn /= 999.0) then
5622 do i=i1_t,i2_t
5623 if(islimsk(i) == 1 .and. sno(i) > 0.0 &
5624 & .and. fld(i) < fldsmn-epsfld) then
5625 kmins = kmins + 1
5626 iwk(kmins) = i
5627 endif
5628 enddo
5629 if(me == 0 . and. it == 1 .and. num_threads == 1) then
5630 nprt = min(mmprt,kmins)
5631 do i=1,nprt
5632 ij = iwk(i)
5633 print 8003,rla(ij),rlo(ij),fld(ij),fldsmn
5634 8003 format(' sno covrd land min. check. lat=',f5.1, &
5635 & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4)
5636 enddo
5637 endif
5638 if (mode == 1) then
5639 do i=1,kmins
5640 fld(iwk(i)) = fldsmn
5641 enddo
5642 endif
5643 endif
5644!
5645! upper bound check over snow covered land
5646!
5647 if (fldsmx /= 999.0) then
5648 do i=i1_t,i2_t
5649 if(islimsk(i) == 1 .and. sno(i) > 0.0 &
5650 & .and. fld(i) > fldsmx+epsfld) then
5651 kmaxs = kmaxs + 1
5652 iwk(kmaxs) = i
5653 endif
5654 enddo
5655 if(me == 0 . and. it == 1 .and. num_threads == 1) then
5656 nprt = min(mmprt,kmaxs)
5657 do i=1,nprt
5658 ij = iwk(i)
5659 print 8004,rla(ij),rlo(ij),fld(ij),fldsmx
5660 8004 format(' snow land max. check. lat=',f5.1, &
5661 & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4)
5662 enddo
5663 endif
5664 if (mode == 1) then
5665 do i=1,kmaxs
5666 fld(iwk(i)) = fldsmx
5667 enddo
5668 endif
5669 endif
5670!
5671! lower bound check over open ocean
5672!
5673 if (fldomn /= 999.0) then
5674 do i=i1_t,i2_t
5675 if(islimsk(i) == 0.0 .and. fld(i) < fldomn-epsfld) then
5676 kmino = kmino + 1
5677 iwk(kmino) = i
5678 endif
5679 enddo
5680 if(me == 0 . and. it == 1 .and. num_threads == 1) then
5681 nprt = min(mmprt,kmino)
5682 do i=1,nprt
5683 ij = iwk(i)
5684 print 8005,rla(ij),rlo(ij),fld(ij),fldomn
5685 8005 format(' open ocean min. check. lat=',f5.1, &
5686 & ' lon=',f6.1,' fld=',e11.4,' to ',e11.4)
5687 enddo
5688 endif
5689 if (mode == 1) then
5690 do i=1,kmino
5691 fld(iwk(i)) = fldomn
5692 enddo
5693 endif
5694 endif
5695!
5696! upper bound check over open ocean
5697!
5698 if (fldomx /= 999.0) then
5699 do i=i1_t,i2_t
5700 if(islimsk(i) ==.0 .and. fld(i) > fldomx+epsfld) then
5701 kmaxo = kmaxo+1
5702 iwk(kmaxo) = i
5703 endif
5704 enddo
5705 if(me == 0 .and. it == 1 .and. num_threads == 1) then
5706 nprt = min(mmprt,kmaxo)
5707 do i=1,nprt
5708 ij = iwk(i)
5709 print 8006,rla(ij),rlo(ij),fld(ij),fldomx
5710 8006 format(' open ocean max. check. lat=',f5.1, &
5711 & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4)
5712 enddo
5713 endif
5714 if (mode == 1) then
5715 do i=1,kmaxo
5716 fld(iwk(i)) = fldomx
5717 enddo
5718 endif
5719 endif
5720!
5721! lower bound check over sea ice without snow
5722!
5723 if (fldimn /= 999.0) then
5724 do i=i1_t,i2_t
5725 if(islimsk(i) == 2 .and. sno(i) <= 0.0 &
5726 & .and. fld(i) < fldimn-epsfld) then
5727 kmini = kmini + 1
5728 iwk(kmini) = i
5729 endif
5730 enddo
5731 if(me == 0 . and. it == 1 .and. num_threads == 1) then
5732 nprt = min(mmprt,kmini)
5733 do i=1,nprt
5734 ij = iwk(i)
5735 print 8007,rla(ij),rlo(ij),fld(ij),fldimn
5736 8007 format(' seaice no snow min. check lat=',f5.1, &
5737 & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4)
5738 enddo
5739 endif
5740 if (mode == 1) then
5741 do i=1,kmini
5742 fld(iwk(i)) = fldimn
5743 enddo
5744 endif
5745 endif
5746!
5747! upper bound check over sea ice without snow
5748!
5749 if (fldimx /= 999.0) then
5750 do i=i1_t,i2_t
5751 if(islimsk(i) == 2 .and. sno(i) <= 0.0 .and. &
5752 & fld(i) > fldimx+epsfld .and. iceflg(i)) then
5753! & fld(i).gt.fldimx+epsfld) then
5754 kmaxi = kmaxi + 1
5755 iwk(kmaxi) = i
5756 endif
5757 enddo
5758 if(me == 0 . and. it == 1 .and. num_threads == 1) then
5759 nprt = min(mmprt,kmaxi)
5760 do i=1,nprt
5761 ij = iwk(i)
5762 print 8008,rla(ij),rlo(ij),fld(ij),fldimx
5763 8008 format(' seaice no snow max. check lat=',f5.1, &
5764 & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4)
5765 enddo
5766 endif
5767 if (mode == 1) then
5768 do i=1,kmaxi
5769 fld(iwk(i)) = fldimx
5770 enddo
5771 endif
5772 endif
5773!
5774! lower bound check over sea ice with snow
5775!
5776 if (fldjmn /= 999.0) then
5777 do i=i1_t,i2_t
5778 if(islimsk(i) == 2 .and. sno(i) > 0.0 .and. &
5779 & fld(i) < fldjmn-epsfld) then
5780 kminj = kminj + 1
5781 iwk(kminj) = i
5782 endif
5783 enddo
5784 if(me == 0 . and. it == 1 .and. num_threads == 1) then
5785 nprt = min(mmprt,kminj)
5786 do i=1,nprt
5787 ij = iwk(i)
5788 print 8009,rla(ij),rlo(ij),fld(ij),fldjmn
5789 8009 format(' sea ice snow min. check lat=',f5.1, &
5790 & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4)
5791 enddo
5792 endif
5793 if (mode == 1) then
5794 do i=1,kminj
5795 fld(iwk(i)) = fldjmn
5796 enddo
5797 endif
5798 endif
5799!
5800! upper bound check over sea ice with snow
5801!
5802 if (fldjmx /= 999.0) then
5803 do i=i1_t,i2_t
5804 if(islimsk(i) == 2 .and.sno(i) > 0.0 .and. &
5805 & fld(i)> fldjmx+epsfld .and. iceflg(i)) then
5806! & fld(i).gt.fldjmx+epsfld) then
5807 kmaxj = kmaxj+1
5808 iwk(kmaxj) = i
5809 endif
5810 enddo
5811 if(me == 0 .and. it == 1 .and. num_threads == 1) then
5812 nprt = min(mmprt,kmaxj)
5813 do i=1,nprt
5814 ij = iwk(i)
5815 print 8010,rla(ij),rlo(ij),fld(ij),fldjmx
5816 8010 format(' seaice snow max check lat=',f5.1, &
5817 & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4)
5818 enddo
5819 endif
5820 if (mode == 1) then
5821 do i=1,kmaxj
5822 fld(iwk(i)) = fldjmx
5823 enddo
5824 endif
5825 endif
5826 enddo ! end of threaded loop
5827!$omp end parallel do
5828!
5829! print results
5830!
5831 if(me == 0) then
5832 permax = 0.0
5833 if(kminl > 0) then
5834 per = float(kminl)/float(len)*100.
5835 print 9001,fldlmn,kminl,per
5836 9001 format(' bare land min check. modified to ',f8.1, &
5837 & ' at ',i5,' points ',f8.1,'percent')
5838 if(per > permax) permax = per
5839 endif
5840 if(kmaxl > 0) then
5841 per = float(kmaxl)/float(len)*100.
5842 print 9002,fldlmx,kmaxl,per
5843 9002 format(' bare land max check. modified to ',f8.1, &
5844 & ' at ',i5,' points ',f5.1,'percent')
5845 if(per.gt.permax) permax=per
5846 endif
5847 if(kmino > 0) then
5848 per = float(kmino)/float(len)*100.
5849 print 9003,fldomn,kmino,per
5850 9003 format(' open ocean min check. modified to ',f8.1, &
5851 & ' at ',i5,' points ',f5.1,'percent')
5852 if(per.gt.permax) permax=per
5853 endif
5854 if(kmaxo > 0) then
5855 per = float(kmaxo)/float(len)*100.
5856 print 9004,fldomx,kmaxo,per
5857 9004 format(' open sea max check. modified to ',f8.1, &
5858 & ' at ',i5,' points ',f5.1,'percent')
5859 if(per.gt.permax) permax=per
5860 endif
5861 if(kmins >.0) then
5862 per = float(kmins)/float(len)*100.
5863 print 9009,fldsmn,kmins,per
5864 9009 format(' snow covered land min check. modified to ',f8.1, &
5865 & ' at ',i5,' points ',f5.1,'percent')
5866 if(per.gt.permax) permax=per
5867 endif
5868 if(kmaxs > 0) then
5869 per = float(kmaxs)/float(len)*100.
5870 print 9010,fldsmx,kmaxs,per
5871 9010 format(' snow covered land max check. modified to ',f8.1, &
5872 & ' at ',i5,' points ',f5.1,'percent')
5873 if(per.gt.permax) permax=per
5874 endif
5875 if(kmini > 0) then
5876 per = float(kmini)/float(len)*100.
5877 print 9005,fldimn,kmini,per
5878 9005 format(' bare ice min check. modified to ',f8.1, &
5879 & ' at ',i5,' points ',f5.1,'percent')
5880 if(per.gt.permax) permax=per
5881 endif
5882 if(kmaxi > 0) then
5883 per = float(kmaxi)/float(len)*100.
5884 print 9006,fldimx,kmaxi,per
5885 9006 format(' bare ice max check. modified to ',f8.1, &
5886 & ' at ',i5,' points ',f5.1,'percent')
5887 if(per > permax) permax=per
5888 endif
5889 if(kminj > 0) then
5890 per = float(kminj)/float(len)*100.
5891 print 9007,fldjmn,kminj,per
5892 9007 format(' snow covered ice min check. modified to ',f8.1, &
5893 & ' at ',i5,' points ',f5.1,'percent')
5894 if(per.gt.permax) permax=per
5895 endif
5896 if(kmaxj > 0) then
5897 per = float(kmaxj)/float(len)*100.
5898 print 9008,fldjmx,kmaxj,per
5899 9008 format(' snow covered ice max check. modified to ',f8.1, &
5900 & ' at ',i5,' points ',f5.1,'percent')
5901 if(per > permax) permax=per
5902 endif
5903! commented on 06/30/99 -- moorthi
5904! if(lgchek) then
5905! if(permax.gt.percrit) then
5906! write(6,*) ' too many bad points. aborting ....'
5907! call abort
5908! endif
5909! endif
5910!
5911 endif
5912!
5913 return
5914 end
5915
5917 subroutine setzro(fld,eps,len)
5918!
5919 use machine , only : kind_io8,kind_io4
5920 implicit none
5921 integer i,len
5922 real (kind=kind_io8) fld(len),eps
5923 do i=1,len
5924 if(abs(fld(i)).lt.eps) fld(i) = 0.
5925 enddo
5926 return
5927 end
5928
5930 subroutine getscv(snofld,scvfld,len)
5931!
5932 use machine , only : kind_io8,kind_io4
5933 implicit none
5934 integer i,len
5935 real (kind=kind_io8) snofld(len),scvfld(len)
5936!
5937 do i=1,len
5938 scvfld(i) = 0.
5939 if(snofld(i).gt.0.) scvfld(i) = 1.
5940 enddo
5941 return
5942 end
5943
5945 subroutine getstc(tsffld,tg3fld,slifld,len,lsoil,stcfld,tsfimx)
5946!
5947 use machine , only : kind_io8,kind_io4
5948 implicit none
5949 integer k,i,len,lsoil
5950 real (kind=kind_io8) factor,tsfimx
5951 real (kind=kind_io8) tsffld(len), tg3fld(len), slifld(len)
5952 real (kind=kind_io8) stcfld(len,lsoil)
5953!
5954! layer soil temperature
5955!
5956 do k = 1, lsoil
5957 do i = 1, len
5958 if(slifld(i).eq.1.0) then
5959 factor = ((k-1) * 2 + 1) / (2. * lsoil)
5960 stcfld(i,k) = factor*tg3fld(i)+(1.-factor)*tsffld(i)
5961 elseif(slifld(i).eq.2.0) then
5962 factor = ((k-1) * 2 + 1) / (2. * lsoil)
5963 stcfld(i,k) = factor*tsfimx+(1.-factor)*tsffld(i)
5964 else
5965 stcfld(i,k) = tg3fld(i)
5966 endif
5967 enddo
5968 enddo
5969 if(lsoil.gt.2) then
5970 do k = 3, lsoil
5971 do i = 1, len
5972 stcfld(i,k) = stcfld(i,2)
5973 enddo
5974 enddo
5975 endif
5976 return
5977 end
5978
5981 subroutine getsmc(wetfld,len,lsoil,smcfld,me)
5982!
5983 use machine , only : kind_io8,kind_io4
5984 implicit none
5985 integer k,i,len,lsoil,me
5986 real (kind=kind_io8) wetfld(len), smcfld(len,lsoil)
5987!
5988 if (me .eq. 0) write(6,*) 'getsmc'
5989!
5990! layer soil wetness
5991!
5992 do k = 1, lsoil
5993 do i = 1, len
5994 smcfld(i,k) = (wetfld(i)*1000./150.)*.37 + .1
5995 enddo
5996 enddo
5997 return
5998 end
5999
6001 subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, &
6002 & tsfimx)
6003!
6004 use machine , only : kind_io8,kind_io4
6005 implicit none
6006 integer i,len,lsoil
6007 real (kind=kind_io8) tsfimx
6008 real (kind=kind_io8) sig1t(len), slianl(len), tg3anl(len)
6009 real (kind=kind_io8) tsfanl(len), stcanl(len,lsoil)
6010!
6011! soil temperature
6012!
6013 if(sig1t(1).gt.0.) then
6014 do i=1,len
6015 if(slianl(i).ne.0.) then
6016 tsfanl(i) = sig1t(i)
6017 endif
6018 enddo
6019 endif
6020 call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx)
6021!
6022 return
6023 end
6024
6026 subroutine snosfc(snoanl,tsfanl,tsfsmx,len,me)
6027 use machine , only : kind_io8,kind_io4
6028 implicit none
6029 integer kount,i,len,me
6030 real (kind=kind_io8) per,tsfsmx
6031 real (kind=kind_io8) snoanl(len), tsfanl(len)
6032!
6033 if (me .eq. 0) write(6,*) 'set snow temp to tsfsmx if greater'
6034 kount=0
6035 do i=1,len
6036 if(snoanl(i).gt.0.) then
6037 if(tsfanl(i).gt.tsfsmx) tsfanl(i)=tsfsmx
6038 kount = kount + 1
6039 endif
6040 enddo
6041 if(kount.gt.0) then
6042 if(me .eq. 0) then
6043 per=float(kount)/float(len)*100.
6044 write(6,*) 'snow sfc. tsf set to ',tsfsmx,' at ',
6045 & kount, ' points ',per,'percent'
6046 endif
6047 endif
6048 return
6049 end
6050
6052 subroutine albocn(albclm,slmask,albomx,len)
6053 use machine , only : kind_io8,kind_io4
6054 implicit none
6055 integer i,len
6056 real (kind=kind_io8) albomx
6057 real (kind=kind_io8) albclm(len,4), slmask(len)
6058 do i=1,len
6059 if(slmask(i) == 0) then
6060 albclm(i,1) = albomx
6061 albclm(i,2) = albomx
6062 albclm(i,3) = albomx
6063 albclm(i,4) = albomx
6064 endif
6065 enddo
6066 return
6067 end
6068
6070 subroutine qcmxice(glacir,amxice,len,me)
6071 use machine , only : kind_io8,kind_io4
6072 implicit none
6073 integer i,kount,len,me
6074 real (kind=kind_io8) glacir(len),amxice(len),per
6075 if (me .eq. 0) write(6,*) 'qc of maximum ice extent'
6076 kount=0
6077 do i=1,len
6078 if(glacir(i).eq.1..and.amxice(i).eq.0.) then
6079 amxice(i) = 0.
6080 kount = kount + 1
6081 endif
6082 enddo
6083 if(kount.gt.0) then
6084 per = float(kount) / float(len)*100.
6085 if(me .eq. 0) write(6,*) ' max ice limit less than glacier'
6086 &, ' coverage at ', kount, ' points ',per,'percent'
6087 endif
6088 return
6089 end
6090
6092 subroutine qcsli(slianl,slifcs,len,me)
6093 use machine , only : kind_io8,kind_io4
6094 implicit none
6095 integer i,kount,len,me
6096 real (kind=kind_io8) slianl(len), slifcs(len),per
6097 if (me .eq. 0) then
6098 write(6,*) ' '
6099 write(6,*) 'qcsli'
6100 endif
6101 kount=0
6102 do i=1,len
6103 if(slianl(i).eq.1..and.slifcs(i).eq.0.) then
6104 kount = kount + 1
6105 slifcs(i) = 1.
6106 endif
6107 if(slianl(i).eq.0..and.slifcs(i).eq.1.) then
6108 kount = kount + 1
6109 slifcs(i) = 0.
6110 endif
6111 if(slianl(i).eq.2..and.slifcs(i).eq.1.) then
6112 kount = kount + 1
6113 slifcs(i) = 0.
6114 endif
6115 if(slianl(i).eq.1..and.slifcs(i).eq.2.) then
6116 kount = kount + 1
6117 slifcs(i) = 1.
6118 endif
6119 enddo
6120 if(kount.gt.0) then
6121 per=float(kount)/float(len)*100.
6122 if(me .eq. 0) then
6123 write(6,*) ' inconsistency of slmask between forecast and',
6124 & ' analysis corrected at ',kount, ' points ',per,
6125 & 'percent'
6126 endif
6127 endif
6128 return
6129 end
6130! subroutine nntprt(data,imax,fact)
6131! real (kind=kind_io8) data(imax)
6132! ilast=0
6133! i1=1
6134! i2=80
6135!1112 continue
6136! if(i2.ge.imax) then
6137! ilast=1
6138! i2=imax
6139! endif
6140! write(6,*) ' '
6141! do j=1,jmax
6142! write(6,1111) (nint(data(imax*(j-1)+i)*fact),i=i1,i2)
6143! enddo
6144! if(ilast.eq.1) return
6145! i1=i1+80
6146! i2=i1+79
6147! if(i2.ge.imax) then
6148! ilast=1
6149! i2=imax
6150! endif
6151! go to 1112
6152!1111 format(80i1)
6153! return
6154! end
6155
6157 subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, &
6158 & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, &
6159 & zoranl,smcanl,smcclm,tsfsmx,albomx,zoromx, me)
6160!
6161 use machine , only : kind_io8,kind_io4
6162 implicit none
6163 integer kount,me,k,i,lsoil,len
6164 real (kind=kind_io8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx
6165 real (kind=kind_io8) tsffcs(len), snofcs(len)
6166 real (kind=kind_io8) snoanl(len), aisanl(len), &
6167 & slianl(len), zoranl(len), &
6168 & tsfanl(len), albanl(len,4), &
6169 & smcanl(len,lsoil), smcclm(len,lsoil)
6170!
6171 if (me == 0) write(6,*) 'qc of snow and sea-ice analysis'
6172!
6173! qc of snow analysis
6174!
6175! questionable snow cover
6176!
6177 kount = 0
6178 do i=1,len
6179 if(slianl(i).gt.0..and. &
6180 & tsffcs(i).gt.qctsfs.and.snoanl(i).gt.0.) then
6181 kount = kount + 1
6182 snoanl(i) = 0.
6183 tsfanl(i) = tsffcs(i)
6184 endif
6185 enddo
6186 if(kount.gt.0) then
6187 per=float(kount)/float(len)*100.
6188 if (me .eq. 0) then
6189 write(6,*) .gt.' guess surface temp ',qctsfs,
6190 & ' but snow analysis indicates snow cover'
6191 write(6,*) ' snow analysis set to zero',
6192 & ' at ',kount, ' points ',per,'percent'
6193 endif
6194 endif
6195!
6196! questionable no snow cover
6197!
6198 kount = 0
6199 do i=1,len
6200 if(slianl(i).gt.0..and.
6201 & snofcs(i).gt.qcsnos.and.snoanl(i).lt.0.) then
6202 kount = kount + 1
6203 snoanl(i) = snofcs(i)
6204 tsfanl(i) = tsffcs(i)
6205 endif
6206 enddo
6207 if(kount.gt.0) then
6208 per=float(kount)/float(len)*100.
6209 if (me .eq. 0) then
6210 write(6,*) .gt.' guess snow depth ',qcsnos,
6211 & ' but snow analysis indicates no snow cover'
6212 write(6,*) ' snow analysis set to guess value',
6213 & ' at ',kount, ' points ',per,'percent'
6214 endif
6215 endif
6216!
6217! questionable sea ice cover ! this qc is disable to correct error in
6218! surface temparature over observed sea ice points
6219!
6220! kount = 0
6221! do i=1,len
6222! if(slianl(i).eq.2..and.
6223! & tsffcs(i).gt.qctsfi.and.aisanl(i).eq.1.) then
6224! kount = kount + 1
6225! aisanl(i) = 0.
6226! slianl(i) = 0.
6227! tsfanl(i) = tsffcs(i)
6228! snoanl(i) = 0.
6229! zoranl(i) = zoromx
6230! albanl(i,1) = albomx
6231! albanl(i,2) = albomx
6232! albanl(i,3) = albomx
6233! albanl(i,4) = albomx
6234! do k=1,lsoil
6235! smcanl(i,k) = smcclm(i,k)
6236! enddo
6237! endif
6238! enddo
6239! if(kount.gt.0) then
6240! per=float(kount)/float(len)*100.
6241! if (me .eq. 0) then
6242! write(6,*) ' guess surface temp .gt. ',qctsfi,
6243! & ' but sea-ice analysis indicates sea-ice'
6244! write(6,*) ' sea-ice analysis set to zero',
6245! & ' at ',kount, ' points ',per,'percent'
6246! endif
6247! endif
6248!
6249 return
6250 end
6251
6253 subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, &
6254 & data,imax,jmax,rlnout,rltout,lmask,rslmsk &
6255 &, gaus,blno, blto, kgds1, kpds4, lbms)
6256 use machine , only : kind_io8,kind_io4,kind_dbl_prec
6257 use sfccyc_module
6258 implicit none
6259 real (kind=kind_io8) blno,blto,wlon,rnlat,crit,data_max
6260 integer i,j,ijmax,jgaul,igaul,kpds5,jmax,imax, kgds1, kspla
6261 integer, intent(in) :: kpds4
6262 logical*1, intent(in) :: lbms(imax,jmax)
6263 real*4 :: dummy(imax,jmax)
6264
6265 real (kind=kind_io8) slmask(igaul,jgaul)
6266 real (kind=kind_io8) data(imax,jmax),rslmsk(imax,jmax)
6267 &, rlnout(imax), rltout(jmax)
6268 real (kind=kind_io8) radi, dlat, dlon
6269 real (kind=kind_dbl_prec) a(jmax), w(jmax)
6270 logical lmask, gaus
6271!
6272! set the longitude and latitudes for the grib file
6273!
6274 if (kgds1 .eq. 4) then ! grib file on gaussian grid
6275 kspla=4
6276 call splat(kspla, jmax, a, w)
6277!
6278 radi = 180.0 / (4.*atan(1.))
6279 do j=1,jmax
6280 rltout(j) = acos(a(j)) * radi
6281 enddo
6282!
6283 if (rnlat .gt. 0.0) then
6284 do j=1,jmax
6285 rltout(j) = 90. - rltout(j)
6286 enddo
6287 else
6288 do j=1,jmax
6289 rltout(j) = -90. + rltout(j)
6290 enddo
6291 endif
6292 elseif (kgds1 .eq. 0) then ! grib file on lat/lon grid
6293 dlat = -(rnlat+rnlat) / float(jmax-1)
6294 do j=1,jmax
6295 rltout(j) = rnlat + (j-1) * dlat
6296 enddo
6297 else ! grib file on some other grid
6298 write(6,*) ' FATAL ERROR: Mask data on'
6299 write(6,*) ' unsupported grid.'
6300 call abort
6301 endif
6302 dlon = 360.0 / imax
6303 do i=1,imax
6304 rlnout(i) = wlon + (i-1)*dlon
6305 enddo
6306!
6307!
6308 ijmax = imax*jmax
6309 rslmsk = 0.
6310! TG3 MODS BEGIN
6311 if(kpds5 == kpdtsf .and. imax == 138 .and. jmax == 116
6312 & .and. kpds4 == 128) then
6313! print*,'turn off setrmsk for tg3'
6314 lmask = .false.
6315
6316 elseif(kpds5 == kpdtsf) then
6317! TG3 MODS END
6318!
6319! surface temperature
6320!
6321 lmask = .false.
6322 call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6323 &, rlnout, rltout, gaus, blno, blto)
6324! &, dlon, dlat, gaus, blno, blto)
6325 crit = 0.5
6326 call rof01(rslmsk,ijmax,'ge',crit)
6327 lmask = .true.
6328!
6329! bucket soil wetness
6330!
6331 elseif(kpds5.eq.kpdwet) then
6332 call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6333 &, rlnout, rltout, gaus, blno, blto)
6334! &, dlon, dlat, gaus, blno, blto)
6335 crit = 0.5
6336 call rof01(rslmsk,ijmax,'ge',crit)
6337 lmask = .true.
6338! write(6,*) 'wet rslmsk'
6339! znnt=1.
6340! call nntprt(rslmsk,ijmax,znnt)
6341!
6342! snow depth
6343!
6344 elseif(kpds5 == kpdsnd) then
6345 if(kpds4 == 192) then ! use the bitmap
6346 rslmsk = 0.
6347 do j = 1, jmax
6348 do i = 1, imax
6349 if (lbms(i,j)) then
6350 rslmsk(i,j) = 1.
6351 end if
6352 enddo
6353 enddo
6354 lmask=.true.
6355 else
6356 lmask=.false.
6357 end if
6358!
6359! snow liq equivalent depth
6360!
6361 elseif(kpds5.eq.kpdsno) then
6362 call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6363 &, rlnout, rltout, gaus, blno, blto)
6364! &, dlon, dlat, gaus, blno, blto)
6365 crit=0.5
6366 call rof01(rslmsk,ijmax,'ge',crit)
6367 lmask=.true.
6368! write(6,*) 'sno rslmsk'
6369! znnt=1.
6370! call nntprt(rslmsk,ijmax,znnt)
6371!
6372! soil moisture
6373!
6374 elseif(kpds5.eq.kpdsmc) then
6375 if(kpds4 == 192) then ! use the bitmap
6376 rslmsk = 0.
6377 do j = 1, jmax
6378 do i = 1, imax
6379 if (lbms(i,j)) then
6380 rslmsk(i,j) = 1.
6381 end if
6382 enddo
6383 enddo
6384 lmask=.true.
6385 else
6386 call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6387 &, rlnout, rltout, gaus, blno, blto)
6388 crit=0.5
6389 call rof01(rslmsk,ijmax,'ge',crit)
6390 lmask=.true.
6391 endif
6392!
6393! surface roughness
6394!
6395 elseif(kpds5.eq.kpdzor) then
6396 do j=1,jmax
6397 do i=1,imax
6398 rslmsk(i,j)=data(i,j)
6399 enddo
6400 enddo
6401 crit=9.9
6402 call rof01(rslmsk,ijmax,'lt',crit)
6403 lmask=.true.
6404! write(6,*) 'zor rslmsk'
6405! znnt=1.
6406! call nntprt(rslmsk,ijmax,znnt)
6407!
6408! albedo
6409!
6410! elseif(kpds5.eq.kpdalb) then
6411! do j=1,jmax
6412! do i=1,imax
6413! rslmsk(i,j)=data(i,j)
6414! enddo
6415! enddo
6416! crit=99.
6417! call rof01(rslmsk,ijmax,'lt',crit)
6418! lmask=.true.
6419! write(6,*) 'alb rslmsk'
6420! znnt=1.
6421! call nntprt(rslmsk,ijmax,znnt)
6422!
6423! albedo
6424!
6425!cbosu new snowfree albedo database has bitmap, use it.
6426 elseif(kpds5.eq.kpdalb(1)) then
6427 if (kpds4 == 192) then ! use the bitmap
6428 rslmsk = 0.
6429 do j = 1, jmax
6430 do i = 1, imax
6431 if (lbms(i,j)) then
6432 rslmsk(i,j) = 1.
6433 end if
6434 enddo
6435 enddo
6436 lmask = .true.
6437 else ! no bitmap. old database has no water flag.
6438 lmask=.false.
6439 end if
6440 elseif(kpds5.eq.kpdalb(2)) then
6441!cbosu
6442 if (kpds4 == 192) then ! use the bitmap
6443 rslmsk = 0.
6444 do j = 1, jmax
6445 do i = 1, imax
6446 if (lbms(i,j)) then
6447 rslmsk(i,j) = 1.
6448 end if
6449 enddo
6450 enddo
6451 lmask = .true.
6452 else ! no bitmap. old database has no water flag.
6453 lmask=.false.
6454 end if
6455 elseif(kpds5.eq.kpdalb(3)) then
6456!cbosu
6457 if (kpds4 == 192) then ! use the bitmap
6458 rslmsk = 0.
6459 do j = 1, jmax
6460 do i = 1, imax
6461 if (lbms(i,j)) then
6462 rslmsk(i,j) = 1.
6463 end if
6464 enddo
6465 enddo
6466 lmask = .true.
6467 else ! no bitmap. old database has no water flag.
6468 lmask=.false.
6469 end if
6470 elseif(kpds5.eq.kpdalb(4)) then
6471!cbosu
6472 if (kpds4 == 192) then ! use the bitmap
6473 rslmsk = 0.
6474 do j = 1, jmax
6475 do i = 1, imax
6476 if (lbms(i,j)) then
6477 rslmsk(i,j) = 1.
6478 end if
6479 enddo
6480 enddo
6481 lmask = .true.
6482 else ! no bitmap. old database has no water flag.
6483 lmask=.false.
6484 end if
6485!
6486! vegetation fraction for albedo
6487!
6488 elseif(kpds5.eq.kpdalf(1)) then
6489! rslmsk=data
6490! crit=0.
6491! call rof01(rslmsk,ijmax,'gt',crit)
6492! lmask=.true.
6493 lmask=.false.
6494 elseif(kpds5.eq.kpdalf(2)) then
6495! rslmsk=data
6496! crit=0.
6497! call rof01(rslmsk,ijmax,'gt',crit)
6498! lmask=.true.
6499 lmask=.false.
6500!
6501! sea ice
6502!
6503 elseif(kpds5.eq.kpdais) then
6504 lmask=.false.
6505! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6506! &, dlon, dlat, gaus, blno, blto)
6507! crit=0.5
6508! call rof01(rslmsk,ijmax,'ge',crit)
6509!
6510 data_max = 0.0
6511 do j=1,jmax
6512 do i=1,imax
6513 rslmsk(i,j) = data(i,j)
6514 data_max= max(data_max,data(i,j))
6515 enddo
6516 enddo
6517 crit=1.0
6518 if (data_max .gt. crit) then
6519 call rof01(rslmsk,ijmax,'gt',crit)
6520 lmask=.true.
6521 else
6522 lmask=.false.
6523 endif
6524! write(6,*) 'acn rslmsk'
6525! znnt=1.
6526! call nntprt(rslmsk,ijmax,znnt)
6527!
6528! deep soil temperature
6529!
6530 elseif(kpds5.eq.kpdtg3) then
6531 lmask=.false.
6532! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6533! &, rlnout, rltout, gaus, blno, blto)
6534! &, dlon, dlat, gaus, blno, blto)
6535! crit=0.5
6536! call rof01(rslmsk,ijmax,'ge',crit)
6537! lmask=.true.
6538!
6539! plant resistance
6540!
6541! elseif(kpds5.eq.kpdplr) then
6542! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6543! &, rlnout, rltout, gaus, blno, blto)
6544! &, dlon, dlat, gaus, blno, blto)
6545! crit=0.5
6546! call rof01(rslmsk,ijmax,'ge',crit)
6547! lmask=.true.
6548!
6549! write(6,*) 'plr rslmsk'
6550! znnt=1.
6551! call nntprt(rslmsk,ijmax,znnt)
6552!
6553! glacier points
6554!
6555 elseif(kpds5.eq.kpdgla) then
6556 lmask=.false.
6557!
6558! max ice extent
6559!
6560 elseif(kpds5.eq.kpdmxi) then
6561 lmask=.false.
6562!
6563! snow cover
6564!
6565 elseif(kpds5.eq.kpdscv) then
6566 call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6567 &, rlnout, rltout, gaus, blno, blto)
6568! &, dlon, dlat, gaus, blno, blto)
6569 crit=0.5
6570 call rof01(rslmsk,ijmax,'ge',crit)
6571 lmask=.true.
6572! write(6,*) 'scv rslmsk'
6573! znnt=1.
6574! call nntprt(rslmsk,ijmax,znnt)
6575!
6576! sea ice concentration
6577!
6578 elseif(kpds5.eq.kpdacn) then
6579 lmask=.false.
6580 call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6581 &, rlnout, rltout, gaus, blno, blto)
6582! &, dlon, dlat, gaus, blno, blto)
6583 crit=0.5
6584 call rof01(rslmsk,ijmax,'ge',crit)
6585 lmask=.true.
6586! write(6,*) 'acn rslmsk'
6587! znnt=1.
6588! call nntprt(rslmsk,ijmax,znnt)
6589!
6590! vegetation cover
6591!
6592 elseif(kpds5.eq.kpdveg) then
6593!cggg
6594 if (kpds4 == 192) then ! use the bitmap
6595 rslmsk = 0.
6596 do j = 1, jmax
6597 do i = 1, imax
6598 if (lbms(i,j)) then
6599 rslmsk(i,jmax-j+1) = 1. ! need to flip grid in n/s direction
6600 end if
6601 enddo
6602 enddo
6603 lmask = .true.
6604 else ! no bitmap, set mask the old way.
6605
6606 call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat
6607 &, rlnout, rltout, gaus, blno, blto)
6608 crit=0.5
6609 call rof01(rslmsk,ijmax,'ge',crit)
6610 lmask=.true.
6611
6612 end if
6613!
6614! soil type
6615!
6616 elseif(kpds5.eq.kpdsot) then
6617
6618 if (kpds4 == 192) then ! use the bitmap
6619 rslmsk = 0.
6620 do j = 1, jmax
6621 do i = 1, imax
6622 if (lbms(i,j)) then
6623 rslmsk(i,j) = 1.
6624 end if
6625 enddo
6626 enddo
6627! soil type is zero over water, use this to get a bitmap.
6628 else
6629 do j = 1, jmax
6630 do i = 1, imax
6631 rslmsk(i,j) = data(i,j)
6632 enddo
6633 enddo
6634 crit=0.1
6635 call rof01(rslmsk,ijmax,'gt',crit)
6636 endif
6637 lmask=.true.
6638!
6639! vegetation type
6640!
6641 elseif(kpds5.eq.kpdvet) then
6642
6643 if (kpds4 == 192) then ! use the bitmap
6644 rslmsk = 0.
6645 do j = 1, jmax
6646 do i = 1, imax
6647 if (lbms(i,j)) then
6648 rslmsk(i,j) = 1.
6649 end if
6650 enddo
6651 enddo
6652! veg type is zero over water, use this to get a bitmap.
6653 else
6654 do j = 1, jmax
6655 do i = 1, imax
6656 rslmsk(i,j) = data(i,j)
6657 enddo
6658 enddo
6659 crit=0.1
6660 call rof01(rslmsk,ijmax,'gt',crit)
6661 endif
6662 lmask=.true.
6663!
6664! these are for four new data type added by clu -- not sure its correct!
6665!
6666 elseif(kpds5.eq.kpdvmn) then
6667!
6668!cggg greenness is zero over water, use this to get a bitmap.
6669!
6670 do j = 1, jmax
6671 do i = 1, imax
6672 rslmsk(i,j) = data(i,j)
6673 enddo
6674 enddo
6675!
6676 crit=0.1
6677 call rof01(rslmsk,ijmax,'gt',crit)
6678 lmask=.true.
6679!cggg lmask=.false.
6680!
6681 elseif(kpds5.eq.kpdvmx) then
6682!
6683!cggg greenness is zero over water, use this to get a bitmap.
6684!
6685 do j = 1, jmax
6686 do i = 1, imax
6687 rslmsk(i,j) = data(i,j)
6688 enddo
6689 enddo
6690!
6691 crit=0.1
6692 call rof01(rslmsk,ijmax,'gt',crit)
6693 lmask=.true.
6694!cggg lmask=.false.
6695!
6696 elseif(kpds5.eq.kpdslp) then
6697!
6698!cggg slope type is zero over water, use this to get a bitmap.
6699!
6700 do j = 1, jmax
6701 do i = 1, imax
6702 rslmsk(i,j) = data(i,j)
6703 enddo
6704 enddo
6705!
6706 crit=0.1
6707 call rof01(rslmsk,ijmax,'gt',crit)
6708 lmask=.true.
6709!cggg lmask=.false.
6710!
6711!cbosu new maximum snow albedo database has bitmap
6712 elseif(kpds5.eq.kpdabs) then
6713 if (kpds4 == 192) then ! use the bitmap
6714 rslmsk = 0.
6715 do j = 1, jmax
6716 do i = 1, imax
6717 if (lbms(i,j)) then
6718 rslmsk(i,j) = 1.
6719 end if
6720 enddo
6721 enddo
6722 lmask = .true.
6723 else ! no bitmap. old database has zero over water
6724 do j = 1, jmax
6725 do i = 1, imax
6726 rslmsk(i,j) = data(i,j)
6727 enddo
6728 enddo
6729 crit=0.1
6730 call rof01(rslmsk,ijmax,'gt',crit)
6731 lmask=.true.
6732 end if
6733 endif
6734!
6735 return
6736 end
6737
6740 subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, &
6741 & wlon,rnlat,rlnout,rltout,gaus,blno, blto)
6742 use machine , only : kind_io8,kind_io4,kind_dbl_prec
6743 use sfccyc_module , only : num_threads
6744 implicit none
6745 integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, &
6746 & j,iret
6747 real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, &
6748 & rnlat,dxout,dphi,dlat,facns,tem,blno, &
6749 & blto
6750!
6751! interpolation from lat/lon grid to other lat/lon grid
6752!
6753 real (kind=kind_io8) gauin(imxin,jmxin), regout(imxout,jmxout) &
6754 &, rlnout(imxout), rltout(jmxout)
6755 logical gaus
6756!
6757 real, allocatable :: gaul(:)
6758 real (kind=kind_io8) ddx(imxout),ddy(jmxout)
6759 integer iindx1(imxout), iindx2(imxout), &
6760 & jindx1(jmxout), jindx2(jmxout)
6761 integer jmxsav,n,kspla
6762 data jmxsav/0/
6763 save jmxsav, gaul, dlati
6764 real (kind=kind_io8) radi
6765 real (kind=kind_dbl_prec) a(jmxin), w(jmxin)
6766!
6767!
6768 logical first
6769 data first /.true./
6770 save first
6771!
6772 integer len_thread_m, j1_t, j2_t, it
6773!
6774 if (first) then
6775 first = .false.
6776 endif
6777!
6778 if (jmxin .ne. jmxsav) then
6779 if (jmxsav .gt. 0) deallocate (gaul, stat=iret)
6780 allocate (gaul(jmxin))
6781 jmxsav = jmxin
6782 if (gaus) then
6783cjfe call gaulat(gaul,jmxin)
6784cjfe
6785!
6786 kspla=4
6787 call splat(kspla, jmxin, a, w)
6788!
6789 radi = 180.0 / (4.*atan(1.))
6790 do n=1,jmxin
6791 gaul(n) = acos(a(n)) * radi
6792 enddo
6793cjfe
6794 do j=1,jmxin
6795 gaul(j) = 90. - gaul(j)
6796 enddo
6797 else
6798 dlat = -2*blto / float(jmxin-1)
6799 dlati = 1 / dlat
6800 do j=1,jmxin
6801 gaul(j) = blto + (j-1) * dlat
6802 enddo
6803 endif
6804 endif
6805!
6806!
6807 dxin = 360. / float(imxin )
6808!
6809 do i=1,imxout
6810 alamd = rlnout(i)
6811 i1 = floor((alamd-blno)/dxin) + 1
6812 ddx(i) = (alamd-blno)/dxin-(i1-1)
6813 iindx1(i) = modulo(i1-1,imxin) + 1
6814 iindx2(i) = modulo(i1 ,imxin) + 1
6815 enddo
6816!
6817!
6818 len_thread_m = (jmxout+num_threads-1) / num_threads
6819!
6820 if (gaus) then
6821!
6822!$omp parallel do private(j1_t,j2_t,it,j1,j2,jj)
6823!$omp+private(aphi)
6824!$omp+shared(num_threads,len_thread_m)
6825!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy)
6826!
6827 do it=1,num_threads ! start of threaded loop ...................
6828 j1_t = (it-1)*len_thread_m+1
6829 j2_t = min(j1_t+len_thread_m-1,jmxout)
6830!
6831 j2=1
6832 do 40 j=j1_t,j2_t
6833 aphi=rltout(j)
6834 do 50 jj=1,jmxin
6835 if(aphi.lt.gaul(jj)) go to 50
6836 j2=jj
6837 go to 42
6838 50 continue
6839 42 continue
6840 if(j2.gt.2) go to 43
6841 j1=1
6842 j2=2
6843 go to 44
6844 43 continue
6845 if(j2.le.jmxin) go to 45
6846 j1=jmxin-1
6847 j2=jmxin
6848 go to 44
6849 45 continue
6850 j1=j2-1
6851 44 continue
6852 jindx1(j)=j1
6853 jindx2(j)=j2
6854 ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1))
6855 40 continue
6856 enddo ! end of threaded loop ...................
6857!$omp end parallel do
6858!
6859 else
6860!$omp parallel do private(j1_t,j2_t,it,j1,j2,jtem)
6861!$omp+private(aphi)
6862!$omp+shared(num_threads,len_thread_m)
6863!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy,dlati,blto)
6864!
6865 do it=1,num_threads ! start of threaded loop ...................
6866 j1_t = (it-1)*len_thread_m+1
6867 j2_t = min(j1_t+len_thread_m-1,jmxout)
6868!
6869 j2=1
6870 do 400 j=j1_t,j2_t
6871 aphi=rltout(j)
6872 jtem = (aphi - blto) * dlati + 1
6873 if (jtem .ge. 1 .and. jtem .lt. jmxin) then
6874 j1 = jtem
6875 j2 = j1 + 1
6876 ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1))
6877 elseif (jtem .eq. jmxin) then
6878 j1 = jmxin
6879 j2 = jmxin
6880 ddy(j)=1.0
6881 else
6882 j1 = 1
6883 j2 = 1
6884 ddy(j)=1.0
6885 endif
6886!
6887 jindx1(j) = j1
6888 jindx2(j) = j2
6889 400 continue
6890 enddo ! end of threaded loop ...................
6891!$omp end parallel do
6892 endif
6893!
6894! write(6,*) 'ga2la'
6895! write(6,*) 'iindx1'
6896! write(6,*) (iindx1(n),n=1,imxout)
6897! write(6,*) 'iindx2'
6898! write(6,*) (iindx2(n),n=1,imxout)
6899! write(6,*) 'jindx1'
6900! write(6,*) (jindx1(n),n=1,jmxout)
6901! write(6,*) 'jindx2'
6902! write(6,*) (jindx2(n),n=1,jmxout)
6903! write(6,*) 'ddy'
6904! write(6,*) (ddy(n),n=1,jmxout)
6905! write(6,*) 'ddx'
6906! write(6,*) (ddx(n),n=1,jmxout)
6907!
6908!
6909!$omp parallel do private(j1_t,j2_t,it,i,i1,i2)
6910!$omp+private(j,j1,j2,x,y)
6911!$omp+shared(num_threads,len_thread_m)
6912!$omp+shared(imxout,iindx1,jindx1,ddx,ddy,gauin,regout)
6913!
6914 do it=1,num_threads ! start of threaded loop ...................
6915 j1_t = (it-1)*len_thread_m+1
6916 j2_t = min(j1_t+len_thread_m-1,jmxout)
6917!
6918 do j=j1_t,j2_t
6919 y = ddy(j)
6920 j1 = jindx1(j)
6921 j2 = jindx2(j)
6922 do i=1,imxout
6923 x = ddx(i)
6924 i1 = iindx1(i)
6925 i2 = iindx2(i)
6926 regout(i,j) = (1.-x)*((1.-y)*gauin(i1,j1) + y*gauin(i1,j2))
6927 & + x *((1.-y)*gauin(i2,j1) + y*gauin(i2,j2))
6928 enddo
6929 enddo
6930 enddo ! end of threaded loop ...................
6931!$omp end parallel do
6932!
6933 sum1 = 0.
6934 sum2 = 0.
6935 do i=1,imxin
6936 sum1 = sum1 + gauin(i,1)
6937 sum2 = sum2 + gauin(i,jmxin)
6938 enddo
6939 sum1 = sum1 / float(imxin)
6940 sum2 = sum2 / float(imxin)
6941!
6942 if (gaus) then
6943 if (rnlat .gt. 0.0) then
6944 do i=1,imxout
6945 regout(i, 1) = sum1
6946 regout(i,jmxout) = sum2
6947 enddo
6948 else
6949 do i=1,imxout
6950 regout(i, 1) = sum2
6951 regout(i,jmxout) = sum1
6952 enddo
6953 endif
6954 else
6955 if (blto .lt. 0.0) then
6956 if (rnlat .gt. 0.0) then
6957 do i=1,imxout
6958 regout(i, 1) = sum2
6959 regout(i,jmxout) = sum1
6960 enddo
6961 else
6962 do i=1,imxout
6963 regout(i, 1) = sum1
6964 regout(i,jmxout) = sum2
6965 enddo
6966 endif
6967 else
6968 if (rnlat .lt. 0.0) then
6969 do i=1,imxout
6970 regout(i, 1) = sum2
6971 regout(i,jmxout) = sum1
6972 enddo
6973 else
6974 do i=1,imxout
6975 regout(i, 1) = sum1
6976 regout(i,jmxout) = sum2
6977 enddo
6978 endif
6979 endif
6980 endif
6981!
6982 return
6983 end
6984
6986 subroutine landtyp(vegtype,soiltype,colortype,slptype,slmask,len)
6987 use machine , only : kind_io8,kind_io4
6988 implicit none
6989 integer i,len
6990 real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) &
6991 &, slptype(len),colortype(len)
6992!
6993! make sure that the soil type and veg type are non-zero over land
6994!
6995 do i = 1, len
6996 if (slmask(i) .eq. 1) then
6997 if (vegtype(i) .eq. 0.) vegtype(i) = 7
6998 if (soiltype(i) .eq. 0.) soiltype(i) = 2
6999 if (colortype(i) .eq. 0.) colortype(i)= 4
7000 if (slptype(i) .eq. 0.) slptype(i) = 1
7001 endif
7002 enddo
7003 return
7004
7005 end subroutine landtyp
7006
7008 subroutine gaulat(gaul,k)
7009!
7010 use machine , only : kind_io8,kind_io4,kind_dbl_prec
7011 implicit none
7012 integer n,k
7013 real (kind=kind_io8) radi
7014 real (kind=kind_io8) gaul(k)
7015 real (kind=kind_dbl_prec) a(k), w(k)
7016!
7017 call splat(4, k, a, w)
7018!
7019 radi = 180.0 / (4.*atan(1.))
7020 do n=1,k
7021 gaul(n) = acos(a(n)) * radi
7022 enddo
7023!
7024 return
7025 70 write(6,6000)
7026 6000 format(//5x,'error in gauaw'//)
7027 stop
7028 end
7029!-----------------------------------------------------------------------
7033 subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len)
7034!
7035 use machine , only : kind_io8,kind_io4
7036 implicit none
7037 integer i,len
7038 real (kind=kind_io8) tsfanl(len), tsfan0(len), &
7039 & tsfclm(len), tsfcl0(len)
7040!
7041! time interpolation of anomalies
7042! add initial anomaly to date interpolated climatology
7043!
7044 write(6,*) 'anomint'
7045 do i=1,len
7046 tsfanl(i) = tsfan0(i) - tsfcl0(i) + tsfclm(i)
7047 enddo
7048 return
7049 end
7050
7052 subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, &
7053 & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, &
7054 & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, &
7055 & fnvetc,fnsotc,fnsocc, &
7056 & fnvmnc,fnvmxc,fnslpc,fnabsc, &
7057 & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm,&
7058 & tg3clm,cvclm ,cvbclm,cvtclm, &
7059 & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm,&
7060 & vetclm,sotclm,socclm,alfclm, &
7061 & vmnclm,vmxclm,slpclm,absclm, &
7062 & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, &
7063 & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, &
7064 & kpdvet,kpdsot,kpdsoc,kpdalf,tsfcl0, &
7065 & kpdvmn,kpdvmx,kpdslp,kpdabs, &
7066 & deltsfc, lanom &
7067 &, imsk, jmsk, slmskh, outlat, outlon &
7068 &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb &
7069 &, tile_num_ch, i_index, j_index)
7070!
7071 use machine , only : kind_io8,kind_io4, kind_dbl_prec
7072 implicit none
7073 character(len=*), intent(in) :: tile_num_ch
7074 integer, intent(in) :: i_index(len), j_index(len)
7075 real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, &
7076 & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2
7077 real (kind=kind_io8) wei1y,wei2y
7078 integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, &
7079 & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, &
7080 & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, &
7081 & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, &
7082 & kpdvet,kpdsot,kpdsoc,kpdstc,kpdveg,jmsk,imsk,j,ialb &
7083 &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat
7084 integer kpdalb(4), kpdalf(2)
7085!
7086 character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, &
7087 & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, &
7088 & fnvetc,fnsotc,fnsocc,fnalbc2 &
7089 &, fnvmnc,fnvmxc,fnslpc,fnabsc
7090 real (kind=kind_io8) tsfclm(len),tsfcl2(len), &
7091 & wetclm(len),snoclm(len), &
7092 & zorclm(len),albclm(len,4),aisclm(len), &
7093 & tg3clm(len),acnclm(len), &
7094 & cvclm (len),cvbclm(len),cvtclm(len), &
7095 & cnpclm(len), &
7096 & smcclm(len,lsoil),stcclm(len,lsoil), &
7097 & sliclm(len),scvclm(len),vegclm(len), &
7098 & vetclm(len),sotclm(len),socclm(len),alfclm(len,2) &
7099 &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len)
7100 real (kind=kind_io8) slmskh(imsk,jmsk)
7101 real (kind=kind_io8) outlat(len), outlon(len)
7102!
7103 real (kind=kind_io8) slmskl(len), slmskw(len), tsfcl0(len)
7104 real (kind=kind_io8), allocatable :: slmask_noice(:)
7105!
7106 logical lanom, gaus, first
7107!
7108! set z0 based on sib vegetation type
7109 real (kind=kind_io8) z0_sib(13)
7110 data z0_sib /2.653, 0.826, 0.563, 1.089, 0.854, 0.856,
7111 & 0.035, 0.238, 0.065, 0.076, 0.011, 0.125,
7112 & 0.011 /
7113! set z0 based on igbp vegetation type
7114 real (kind=kind_io8) z0_igbp_min(20), z0_igbp_max(20)
7115 real (kind=kind_io8) z0_season(12)
7116 data z0_igbp_min /1.089, 2.653, 0.854, 0.826, 0.800, 0.050,
7117 & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130,
7118 & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076,
7119 & 0.050, 0.030/
7120 data z0_igbp_max /1.089, 2.653, 0.854, 0.826, 0.800, 0.050,
7121 & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130,
7122 & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076,
7123 & 0.050, 0.030/
7124!
7125! dayhf : julian day of the middle of each month
7126!
7127 real (kind=kind_io8) dayhf(13)
7128 data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0,
7129 & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/
7130!
7131 real (kind=kind_dbl_prec) fha(5)
7132 integer ida(8),jda(8),ivtyp, kpd7
7133!
7134 real (kind=kind_io8), allocatable :: tsf(:,:),sno(:,:),
7135 & zor(:,:),wet(:,:),
7136 & ais(:,:), acn(:,:), scv(:,:), smc(:,:,:),
7137 & tg3(:), alb(:,:,:), alf(:,:),
7138 & vet(:), sot(:), soc(:), tsf2(:),
7139 & veg(:,:), stc(:,:,:)
7140 &, vmn(:), vmx(:), slp(:), absm(:)
7141!
7142 integer mon1s, mon2s, sea1s, sea2s, sea1, sea2, hyr1, hyr2
7143 data first/.true./
7144 data mon1s/0/, mon2s/0/, sea1s/0/, sea2s/0/
7145!
7146 save first, tsf, sno, zor, wet, ais, acn, scv, smc, tg3,
7147 & alb, alf, vet, sot, soc,tsf2, veg, stc,
7148 & vmn, vmx, slp, absm,
7149 & mon1s, mon2s, sea1s, sea2s, dayhf, k1, k2, m1, m2,
7150 & landice_cat
7151!
7152 logical lprnt
7153!
7154 do i=1,len
7155 tsfclm(i) = 0.0
7156 tsfcl2(i) = 0.0
7157 snoclm(i) = 0.0
7158 wetclm(i) = 0.0
7159 zorclm(i) = 0.0
7160 aisclm(i) = 0.0
7161 tg3clm(i) = 0.0
7162 acnclm(i) = 0.0
7163 cvclm(i) = 0.0
7164 cvbclm(i) = 0.0
7165 cvtclm(i) = 0.0
7166 cnpclm(i) = 0.0
7167 sliclm(i) = slmskl(i)
7168 scvclm(i) = 0.0
7169 vmnclm(i) = 0.0
7170 vmxclm(i) = 0.0
7171 slpclm(i) = 0.0
7172 absclm(i) = 0.0
7173 enddo
7174 do k=1,lsoil
7175 do i=1,len
7176 smcclm(i,k) = 0.0
7177 stcclm(i,k) = 0.0
7178 enddo
7179 enddo
7180 do k=1,4
7181 do i=1,len
7182 albclm(i,k) = 0.0
7183 enddo
7184 enddo
7185 do k=1,2
7186 do i=1,len
7187 alfclm(i,k) = 0.0
7188 enddo
7189 enddo
7190!
7191 iret = 0
7192 monend = 9999
7193!
7194 if (first) then
7195!
7196! allocate variables to be saved
7197!
7198 allocate (tsf(len,2), sno(len,2), zor(len,2),
7199 & wet(len,2), ais(len,2), acn(len,2),
7200 & scv(len,2), smc(len,lsoil,2),
7201 & tg3(len), alb(len,4,2), alf(len,2),
7202 & vet(len), sot(len), soc(len),tsf2(len),
7203!clu [+1l] add vmn, vmx, slp, abs
7204 & vmn(len), vmx(len), slp(len), absm(len),
7205 & veg(len,2), stc(len,lsoil,2))
7206!
7207! get tsf climatology for the begining of the forecast
7208!
7209 if (fh > 0.0) then
7210!cbosu
7211 if (me == 0) print*,'bosu fh gt 0'
7212
7213 iy4 = iy
7214 if (iy < 101) iy4 = 1900 + iy4
7215 fha = 0
7216 ida = 0
7217 jda = 0
7218! fha(2) = nint(fh)
7219 ida(1) = iy
7220 ida(2) = im
7221 ida(3) = id
7222 ida(5) = ih
7223 call w3movdat(fha,ida,jda)
7224 jy = jda(1)
7225 jm = jda(2)
7226 jd = jda(3)
7227 jh = jda(5)
7228 if (me == 0) write(6,*) ' forecast jy,jm,jd,jh',
7229 & jy,jm,jd,jh
7230 jdow = 0
7231 jdoy = 0
7232 jday = 0
7233 call w3doxdat(jda,jdow,jdoy,jday)
7234 rjday = jdoy + jda(5) / 24.
7235 if(rjday < dayhf(1)) rjday = rjday + 365.
7236!
7237 if (me == 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh
7238!
7239! for monthly mean climatology
7240!
7241 monend = 12
7242 do mm=1,monend
7243 mmm = mm
7244 mmp = mm + 1
7245 if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then
7246 mon1 = mmm
7247 mon2 = mmp
7248 go to 10
7249 endif
7250 enddo
7251 print *,'FATAL ERROR: wrong rjday',rjday
7252 call abort
7253 10 continue
7254 wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1))
7255 wei2m = 1.0 - wei1m
7256! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1))
7257 if (mon2 == 13) mon2 = 1
7258 if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=',
7259 & rjday,mon1,mon2,wei1m,wei2m
7260!
7261! read monthly mean climatology of tsf
7262!
7263 kpd7 = -1
7264 do nn=1,2
7265 mon = mon1
7266 if (nn == 2) mon = mon2
7267 call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw,
7268 & tsf(1,nn),len,iret
7269 &, imsk, jmsk, slmskh, gaus,blno, blto
7270 &, outlat, outlon, me)
7271 enddo
7272!
7273! tsf at the begining of forecast i.e. fh=0
7274!
7275 do i=1,len
7276 tsfcl0(i) = wei1m * tsf(i,1) + wei2m * tsf(i,2)
7277 enddo
7278 endif
7279 endif
7280!
7281! compute current jy,jm,jd,jh of forecast and the day of the year
7282!
7283 iy4 = iy
7284 if (iy < 101) iy4=1900+iy4
7285 fha = 0
7286 ida = 0
7287 jda = 0
7288 fha(2) = nint(fh)
7289 ida(1) = iy
7290 ida(2) = im
7291 ida(3) = id
7292 ida(5) = ih
7293 call w3movdat(fha,ida,jda)
7294 jy = jda(1)
7295 jm = jda(2)
7296 jd = jda(3)
7297 jh = jda(5)
7298! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=',
7299! & jy,jm,jd,jh,rjday
7300 jdow = 0
7301 jdoy = 0
7302 jday = 0
7303 call w3doxdat(jda,jdow,jdoy,jday)
7304 rjday = jdoy + jda(5) / 24.
7305 if(rjday < dayhf(1)) rjday = rjday + 365.
7306
7307 if (me == 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=',
7308 & jy,jm,jd,jh,rjday
7309!
7310 if (me == 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh
7311!
7312! for monthly mean climatology
7313!
7314 monend = 12
7315 do mm=1,monend
7316 mmm = mm
7317 mmp = mm + 1
7318 if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then
7319 mon1 = mmm
7320 mon2 = mmp
7321 go to 20
7322 endif
7323 enddo
7324 print *,'FATAL ERROR: wrong rjday',rjday
7325 call abort
7326 20 continue
7327 wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1))
7328 wei2m = 1.0 - wei1m
7329! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1))
7330 if (mon2 == 13) mon2 = 1
7331 if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=',
7332 & rjday,mon1,mon2,wei1m,wei2m
7333!
7334! for seasonal mean climatology
7335!
7336 monend = 4
7337 is = im/3 + 1
7338 if (is == 5) is = 1
7339 do mm=1,monend
7340 mmm = mm*3 - 2
7341 mmp = (mm+1)*3 - 2
7342 if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then
7343 sea1 = mmm
7344 sea2 = mmp
7345 go to 30
7346 endif
7347 enddo
7348 print *,'FATAL ERROR: wrong rjday',rjday
7349 call abort
7350 30 continue
7351 wei1s = (dayhf(sea2)-rjday)/(dayhf(sea2)-dayhf(sea1))
7352 wei2s = 1.0 - wei1s
7353! wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1))
7354 if (sea2 == 13) sea2 = 1
7355 if (me == 0) print *,'rjday,sea1,sea2,wei1s,wei2s=',
7356 & rjday,sea1,sea2,wei1s,wei2s
7357!
7358! for summer and winter values (maximum and minimum).
7359!
7360 monend = 2
7361 is = im/6 + 1
7362 if (is == 3) is = 1
7363 do mm=1,monend
7364 mmm = mm*6 - 5
7365 mmp = (mm+1)*6 - 5
7366 if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then
7367 hyr1 = mmm
7368 hyr2 = mmp
7369 go to 31
7370 endif
7371 enddo
7372 print *,'FATAL ERROR: wrong rjday',rjday
7373 call abort
7374 31 continue
7375 wei1y = (dayhf(hyr2)-rjday)/(dayhf(hyr2)-dayhf(hyr1))
7376 wei2y = 1.0 - wei1y
7377! wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1))
7378 if (hyr2 == 13) hyr2 = 1
7379 if (me == 0) print *,'rjday,hyr1,hyr2,wei1y,wei2y=',
7380 & rjday,hyr1,hyr2,wei1y,wei2y
7381!
7382! start reading in climatology and interpolate to the date
7383!
7384 first_time : if (first) then
7385!cbosu
7386 if (me == 0) print*,'bosu first time thru'
7387!
7388! annual mean climatology
7389!
7390! fraction of vegetation field for albedo -- there are two
7391! fraction fields in this version: strong zenith angle dependent
7392! and weak zenith angle dependent
7393!
7394 kpd9 = -1
7395cjfe
7396 alf=0.
7397cjfe
7398
7399 kpd7=-1
7400 if (ialb == 1 .or. ialb == 2) then
7401!cbosu still need facsf and facwf. read them from the production file
7402 if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file
7403 call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmskl
7404 &, alf,len,iret
7405 &, imsk, jmsk, slmskh, gaus,blno, blto
7406 &, outlat, outlon, me)
7407 else
7408 call fixrdc_tile(fnalbc2, tile_num_ch, i_index, j_index,
7409 & kpdalf(1), alf(:,1), 1, len, me)
7410 endif
7411 else
7412 call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmskl
7413 &, alf,len,iret
7414 &, imsk, jmsk, slmskh, gaus,blno, blto
7415 &, outlat, outlon, me)
7416 endif
7417 do i = 1, len
7418 if(slmskl(i) == 1.) then
7419 alf(i,2) = 100. - alf(i,1)
7420 endif
7421 enddo
7422!
7423! deep soil temperature
7424!
7425 if(fntg3c(1:8).ne.' ') then
7426 if ( index(fntg3c, "tileX.nc") == 0) then ! grib file
7427 kpd7=-1
7428 call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmskl,
7429 & tg3,len,iret
7430 &, imsk, jmsk, slmskh, gaus,blno, blto
7431 &, outlat, outlon, me)
7432 else
7433 call fixrdc_tile(fntg3c, tile_num_ch, i_index, j_index,
7434 & kpdtg3, tg3, 1, len, me)
7435 endif
7436 endif
7437!
7438! vegetation type
7439!
7440! when using the new gldas soil moisture climatology, a veg type
7441! dataset must be selected.
7442!
7443 if(fnvetc(1:8).ne.' ') then
7444 if ( index(fnvetc, "tileX.nc") == 0) then ! grib file
7445 kpd7=-1
7446 call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmskl,
7447 & vet,len,iret
7448 &, imsk, jmsk, slmskh, gaus,blno, blto
7449 &, outlat, outlon, me)
7450 landice_cat=13
7451 if (maxval(vet)> 13.0) landice_cat=15
7452 else
7453 call fixrdc_tile(fnvetc, tile_num_ch, i_index, j_index,
7454 & kpdvet, vet, 1, len, me)
7455 landice_cat=15
7456 endif
7457 if (me .eq. 0) write(6,*) 'climatological vegetation',
7458 & ' type read in.'
7459 elseif(index(fnsmcc,'soilmgldas') /= 0) then ! new soil moisture climo
7460 if (me .eq. 0) then
7461 write(6,*) 'FATAL ERROR: must choose'
7462 write(6,*) 'climatological veg type when'
7463 write(6,*) 'using new gldas soil moisture.'
7464 endif
7465 call abort
7466 endif
7467!
7468 if(fnsotc(1:8).ne.' ') then
7469 if ( index(fnsotc, "tileX.nc") == 0) then ! grib file
7470 kpd7=-1
7471 call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmskl,
7472 & sot,len,iret
7473 &, imsk, jmsk, slmskh, gaus,blno, blto
7474 &, outlat, outlon, me)
7475 else
7476 call fixrdc_tile(fnsotc, tile_num_ch, i_index, j_index,
7477 & kpdsot, sot, 1, len, me)
7478 endif
7479 if (me .eq. 0) write(6,*) 'climatological soil type read in.'
7480 endif
7481
7482!
7483! soil color
7484!
7485 If(fnsocc(1:8).ne.' ') then
7486 if ( index(fnsocc, "tileX.nc") == 0) then ! grib file
7487 kpd7=-1
7488 call fixrdc(lugb,fnsocc,kpdsoc,kpd7,kpd9,slmskl,
7489 & soc,len,iret
7490 &, imsk, jmsk, slmskh, gaus,blno, blto
7491 &, outlat, outlon, me)
7492 else
7493 call fixrdc_tile(fnsocc, tile_num_ch, i_index, j_index,
7494 & 255, soc, 1, len, me)
7495 if (me .eq. 0) write(6,*) 'Soil color data name is',fnsocc
7496 endif
7497 if (me .eq. 0) write(6,*) 'climatological soil color read in.'
7498 endif
7499
7500!
7501! min vegetation cover
7502!
7503 if(fnvmnc(1:8).ne.' ') then
7504 if ( index(fnvmnc, "tileX.nc") == 0) then ! grib file
7505 kpd7=-1
7506 call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmskl,
7507 & vmn,len,iret
7508 &, imsk, jmsk, slmskh, gaus,blno, blto
7509 &, outlat, outlon, me)
7510 else
7511 call fixrdc_tile(fnvmnc, tile_num_ch, i_index, j_index,
7512 & 257, vmn, 99, len, me)
7513
7514 endif
7515 if (me .eq. 0) write(6,*) 'climatological shdmin read in.'
7516 endif
7517!
7518! max vegetation cover
7519!
7520 if(fnvmxc(1:8).ne.' ') then
7521 if ( index(fnvmxc, "tileX.nc") == 0) then ! grib file
7522 kpd7=-1
7523 call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmskl,
7524 & vmx,len,iret
7525 &, imsk, jmsk, slmskh, gaus,blno, blto
7526 &, outlat, outlon, me)
7527 else
7528 call fixrdc_tile(fnvmxc, tile_num_ch, i_index, j_index,
7529 & 256, vmx, 99, len, me)
7530 endif
7531 if (me .eq. 0) write(6,*) 'climatological shdmax read in.'
7532 endif
7533!
7534! slope type
7535!
7536 if(fnslpc(1:8).ne.' ') then
7537 if ( index(fnslpc, "tileX.nc") == 0) then ! grib file
7538 kpd7=-1
7539 call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmskl,
7540 & slp,len,iret
7541 &, imsk, jmsk, slmskh, gaus,blno, blto
7542 &, outlat, outlon, me)
7543 else
7544 call fixrdc_tile(fnslpc, tile_num_ch, i_index, j_index,
7545 & kpdslp, slp, 1, len, me)
7546 endif
7547 if (me .eq. 0) write(6,*) 'climatological slope read in.'
7548 endif
7549!
7550! max snow albedo
7551!
7552 if(fnabsc(1:8).ne.' ') then
7553 if ( index(fnabsc, "tileX.nc") == 0) then ! grib file
7554 kpd7=-1
7555 call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmskl,
7556 & absm,len,iret
7557 &, imsk, jmsk, slmskh, gaus,blno, blto
7558 &, outlat, outlon, me)
7559 else
7560 call fixrdc_tile(fnabsc, tile_num_ch, i_index, j_index,
7561 & kpdabs, absm, 1, len, me)
7562 endif
7563 if (me .eq. 0) write(6,*) 'climatological snoalb read in.'
7564 endif
7565!clu ----------------------------------------------------------------------
7566!
7567 is1 = sea1/3 + 1
7568 is2 = sea2/3 + 1
7569 if (is1 == 5) is1 = 1
7570 if (is2 == 5) is2 = 1
7571 do nn=1,2
7572!
7573! seasonal mean climatology
7574 if(nn == 1) then
7575 isx = is1
7576 else
7577 isx = is2
7578 endif
7579 if(isx == 1) kpd9 = 12
7580 if(isx == 2) kpd9 = 3
7581 if(isx == 3) kpd9 = 6
7582 if(isx == 4) kpd9 = 9
7583!
7584! seasonal mean climatology
7585!
7586! albedo
7587! there are four albedo fields in this version:
7588! two for strong zeneith angle dependent (visible and near ir)
7589! and two for weak zeneith angle dependent (vis ans nir)
7590!
7591 if (ialb == 0) then
7592 kpd7=-1
7593 do k = 1, 4
7594 call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmskl,
7595 & alb(1,k,nn),len,iret
7596 &, imsk, jmsk, slmskh, gaus,blno, blto
7597 &, outlat, outlon, me)
7598 enddo
7599 endif
7600!
7601! monthly mean climatology
7602!
7603 mon = mon1
7604 if (nn .eq. 2) mon = mon2
7605!cbosu
7606!cbosu new snowfree albedo database is monthly.
7607 if (ialb == 1 .or. ialb == 2) then
7608 if ( index(fnalbc, "tileX.nc") == 0) then ! grib file
7609 kpd7=-1
7610 do k = 1, 4
7611 call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl,
7612 & alb(1,k,nn),len,iret
7613 &, imsk, jmsk, slmskh, gaus,blno, blto
7614 &, outlat, outlon, me)
7615 enddo
7616 else
7617 do k = 1, 4
7618 call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index,
7619 & kpdalb(k), alb(:,k,nn), mon, len, me)
7620 enddo
7621 endif
7622 endif
7623
7624! if(lprnt) print *,' mon1=',mon1,' mon2=',mon2
7625!
7626! tsf at the current time t
7627!
7628 kpd7=-1
7629 call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw,
7630 & tsf(1,nn),len,iret
7631 &, imsk, jmsk, slmskh, gaus,blno, blto
7632 &, outlat, outlon, me)
7633! if(lprnt) print *,' tsf=',tsf(iprnt,nn),' nn=',nn
7634!
7635! tsf...at time t-deltsfc
7636!
7637! fh2 = fh - deltsfc
7638! if (fh2 .gt. 0.0) then
7639! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmskw,
7640! & iy,im,id,ih,fh2,tsfcl2,len,iret
7641! &, imsk, jmsk, slmskh, gaus,blno, blto
7642! &, outlat, outlon, me)
7643! else
7644! do i=1,len
7645! tsfcl2(i) = tsfclm(i)
7646! enddo
7647! endif
7648!
7649! soil wetness
7650!
7651 if(fnwetc(1:8).ne.' ') then
7652 kpd7=-1
7653 call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmskl,
7654 & wet(1,nn),len,iret
7655 &, imsk, jmsk, slmskh, gaus,blno, blto
7656 &, outlat, outlon, me)
7657 elseif(fnsmcc(1:8).ne.' ') then
7658 if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data
7659 kpd7=-1
7660 call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmskl,
7661 & smc(1,lsoil,nn),len,iret
7662 &, imsk, jmsk, slmskh, gaus,blno, blto
7663 &, outlat, outlon, me)
7664 do l=1,lsoil-1
7665 do i = 1, len
7666 smc(i,l,nn) = smc(i,lsoil,nn)
7667 enddo
7668 enddo
7669 else ! the new gldas data. it does not have data defined at landice
7670 ! points. so for efficiency, don't have fixrdc try to
7671 ! find a value at landice points as defined by the vet type (vet).
7672 allocate(slmask_noice(len))
7673 slmask_noice = slmskl
7674 do i = 1, len
7675 if (nint(vet(i)) < 1 .or.
7676 & nint(vet(i)) == landice_cat) then
7677 slmask_noice(i) = 0.0
7678 endif
7679 enddo
7680 do k = 1, lsoil
7681 if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12)
7682 if (k==2) kpd7=2600 ! 10_40 cm
7683 if (k==3) kpd7=10340 ! 40_100 cm
7684 if (k==4) kpd7=25800 ! 100_200 cm
7685 call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice,
7686 & smc(1,k,nn),len,iret
7687 &, imsk, jmsk, slmskh, gaus,blno, blto
7688 &, outlat, outlon, me)
7689 enddo
7690 deallocate(slmask_noice)
7691 endif
7692 else
7693 write(6,*) 'FATAL ERROR: climatological soil wetness'
7694 write(6,*) 'file not given.'
7695 call abort
7696 endif
7697!
7698! soil temperature
7699!
7700 if(fnstcc(1:8).ne.' ') then
7701 kpd7=-1
7702 call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmskl,
7703 & stc(1,lsoil,nn),len,iret
7704 &, imsk, jmsk, slmskh, gaus,blno, blto
7705 &, outlat, outlon, me)
7706 do l=1,lsoil-1
7707 do i = 1, len
7708 stc(i,l,nn) = stc(i,lsoil,nn)
7709 enddo
7710 enddo
7711 endif
7712!
7713! sea ice
7714!
7715 kpd7=-1
7716 if(fnacnc(1:8).ne.' ') then
7717 call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmskw,
7718 & acn(1,nn),len,iret
7719 &, imsk, jmsk, slmskh, gaus,blno, blto
7720 &, outlat, outlon, me)
7721 elseif(fnaisc(1:8).ne.' ') then
7722 call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmskw,
7723 & ais(1,nn),len,iret
7724 &, imsk, jmsk, slmskh, gaus,blno, blto
7725 &, outlat, outlon, me)
7726 else
7727 write(6,*) 'FATAL ERROR: climatological ice cover'
7728 write(6,*) 'file not given.'
7729 call abort
7730 endif
7731!
7732! snow depth
7733!
7734 kpd7=-1
7735 call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmskl,
7736 & sno(1,nn),len,iret
7737 &, imsk, jmsk, slmskh, gaus,blno, blto
7738 &, outlat, outlon, me)
7739!
7740! snow cover
7741!
7742 if(fnscvc(1:8).ne.' ') then
7743 kpd7=-1
7744 call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmskl,
7745 & scv(1,nn),len,iret
7746 &, imsk, jmsk, slmskh, gaus,blno, blto
7747 &, outlat, outlon, me)
7748 write(6,*) 'climatological snow cover read in.'
7749 endif
7750!
7751! surface roughness
7752!
7753 if(fnzorc(1:3) == 'sib') then
7754 if (me == 0) then
7755 write(6,*) 'roughness length to be set from sib veg type'
7756 endif
7757 elseif(fnzorc(1:4) == 'igbp') then
7758 if (me == 0) then
7759 write(6,*) 'roughness length to be set from igbp veg type'
7760 endif
7761 else
7762 kpd7=-1
7763 call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmskl,
7764 & zor(1,nn),len,iret
7765 &, imsk, jmsk, slmskh, gaus,blno, blto
7766 &, outlat, outlon, me)
7767 endif
7768!
7769 do i = 1, len
7770! set clouds climatology to zero
7771 cvclm(i) = 0.
7772 cvbclm(i) = 0.
7773 cvtclm(i) = 0.
7774!
7775 cnpclm(i) = 0. !set canopy water content climatology to zero
7776 enddo
7777!
7778! vegetation cover
7779!
7780 if(fnvegc(1:8).ne.' ') then
7781 if ( index(fnvegc, "tileX.nc") == 0) then ! grib file
7782 kpd7=-1
7783 call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmskl,
7784 & veg(1,nn),len,iret
7785 &, imsk, jmsk, slmskh, gaus,blno, blto
7786 &, outlat, outlon, me)
7787 else
7788 call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index,
7789 & kpdveg, veg(:,nn), mon, len, me)
7790 endif
7791 if (me .eq. 0) write(6,*) 'climatological vegetation',
7792 & ' cover read in for mon=',mon
7793 endif
7794
7795 enddo
7796!
7797 mon1s = mon1 ; mon2s = mon2 ; sea1s = sea1 ; sea2s = sea2
7798!
7799 if (me == 0) print *,' mon1s=',mon1s,' mon2s=',mon2s
7800 &,' sea1s=',sea1s,' sea2s=',sea2s
7801!
7802 k1 = 1 ; k2 = 2
7803 m1 = 1 ; m2 = 2
7804!
7805 first = .false.
7806 endif first_time
7807!
7808! to get tsf climatology at the previous call to sfccycle
7809!
7810! if (fh-deltsfc >= 0.0) then
7811 rjdayh = rjday - deltsfc/24.0
7812! else
7813! rjdayh = rjday
7814! endif
7815! if(lprnt) print *,' rjdayh=',rjdayh,' mon1=',mon1,' mon2='
7816! &,mon2,' mon1s=',mon1s,' mon2s=',mon2s,' k1=',k1,' k2=',k2
7817 if (rjdayh .ge. dayhf(mon1)) then
7818 if (mon2 .eq. 1) mon2 = 13
7819 wei1x = (dayhf(mon2)-rjdayh)/(dayhf(mon2)-dayhf(mon1))
7820 wei2x = 1.0 - wei1x
7821 if (mon2 .eq. 13) mon2 = 1
7822 else
7823 rjdayh2 = rjdayh
7824 if (rjdayh .lt. dayhf(1)) rjdayh2 = rjdayh2 + 365.0
7825 if (mon1s .eq. mon1) then
7826 mon1s = mon1 - 1
7827 if (mon1s .eq. 0) mon1s = 12
7828 k2 = k1
7829 k1 = mod(k2,2) + 1
7830 mon = mon1s
7831 kpd7=-1
7832 call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw,
7833 & tsf(1,k1),len,iret
7834 &, imsk, jmsk, slmskh, gaus,blno, blto
7835 &, outlat, outlon, me)
7836 endif
7837 mon2s = mon1s + 1
7838! if (mon2s .eq. 1) mon2s = 13
7839 wei1x = (dayhf(mon2s)-rjdayh2)/(dayhf(mon2s)-dayhf(mon1s))
7840 wei2x = 1.0 - wei1x
7841 if (mon2s .eq. 13) mon2s = 1
7842 do i=1,len
7843 tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2)
7844 enddo
7845 endif
7846!
7847!cbosu new albedo is monthly
7848 if (sea1 .ne. sea1s) then
7849 sea1s = sea1
7850 sea2s = sea2
7851 m1 = mod(m1,2) + 1
7852 m2 = mod(m1,2) + 1
7853!
7854! seasonal mean climatology
7855!
7856 isx = sea2/3 + 1
7857 if (isx == 5) isx = 1
7858 if (isx == 1) kpd9 = 12
7859 if (isx == 2) kpd9 = 3
7860 if (isx == 3) kpd9 = 6
7861 if (isx == 4) kpd9 = 9
7862!
7863! albedo
7864! there are four albedo fields in this version:
7865! two for strong zeneith angle dependent (visible and near ir)
7866! and two for weak zeneith angle dependent (vis ans nir)
7867!
7868!cbosu
7869 if (ialb == 0) then
7870 kpd7=-1
7871 do k = 1, 4
7872 call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmskl
7873 &, alb(1,k,m2),len,iret
7874 &, imsk, jmsk, slmskh, gaus,blno, blto
7875 &, outlat, outlon, me)
7876 enddo
7877 endif
7878
7879 endif
7880
7881 if (mon1 .ne. mon1s) then
7882
7883 mon1s = mon1
7884 mon2s = mon2
7885 k1 = mod(k1,2) + 1
7886 k2 = mod(k1,2) + 1
7887!
7888! monthly mean climatology
7889!
7890 mon = mon2
7891 nn = k2
7892!cbosu
7893 if (ialb == 1 .or. ialb == 2) then
7894 if (me == 0) print*,'bosu 2nd time in clima for month ',
7895 & mon, k1,k2
7896 if ( index(fnalbc, "tileX.nc") == 0) then ! grib file
7897 kpd7 = -1
7898 do k = 1, 4
7899 call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl,
7900 & alb(1,k,nn),len,iret
7901 &, imsk, jmsk, slmskh, gaus,blno, blto
7902 &, outlat, outlon, me)
7903 enddo
7904 else
7905 do k = 1, 4
7906 call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index,
7907 & kpdalb(k), alb(:,k,nn), mon, len, me)
7908 enddo
7909 endif
7910 endif
7911!
7912! tsf at the current time t
7913!
7914 kpd7 = -1
7915 call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw,
7916 & tsf(1,nn),len,iret
7917 &, imsk, jmsk, slmskh, gaus,blno, blto
7918 &, outlat, outlon, me)
7919!
7920! soil wetness
7921!
7922 if (fnwetc(1:8).ne.' ') then
7923 kpd7=-1
7924 call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmskl,
7925 & wet(1,nn),len,iret
7926 &, imsk, jmsk, slmskh, gaus,blno, blto
7927 &, outlat, outlon, me)
7928 elseif (fnsmcc(1:8).ne.' ') then
7929 if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data
7930 kpd7=-1
7931 call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmskl,
7932 & smc(1,lsoil,nn),len,iret
7933 &, imsk, jmsk, slmskh, gaus,blno, blto
7934 &, outlat, outlon, me)
7935 do l=1,lsoil-1
7936 do i = 1, len
7937 smc(i,l,nn) = smc(i,lsoil,nn)
7938 enddo
7939 enddo
7940 else ! the new gldas data. it does not have data defined at landice
7941 ! points. so for efficiency, don't have fixrdc try to
7942 ! find a value at landice points as defined by the vet type (vet).
7943 allocate(slmask_noice(len))
7944 slmask_noice=1.0
7945 do i = 1, len
7946 if (nint(vet(i)) < 1 .or.
7947 & nint(vet(i)) == landice_cat) then
7948 slmask_noice(i) = 0.0
7949 endif
7950 enddo
7951 do k = 1, lsoil
7952 if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12)
7953 if (k==2) kpd7=2600 ! 10_40 cm
7954 if (k==3) kpd7=10340 ! 40_100 cm
7955 if (k==4) kpd7=25800 ! 100_200 cm
7956 call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice,
7957 & smc(1,k,nn),len,iret
7958 &, imsk, jmsk, slmskh, gaus,blno, blto
7959 &, outlat, outlon, me)
7960 enddo
7961 deallocate(slmask_noice)
7962 endif
7963 else
7964 write(6,*) 'FATAL ERROR: climatological soil wetness'
7965 write(6,*) 'file not given.'
7966 call abort
7967 endif
7968!
7969! sea ice
7970!
7971 kpd7 = -1
7972 if (fnacnc(1:8).ne.' ') then
7973 call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmskw,
7974 & acn(1,nn),len,iret
7975 &, imsk, jmsk, slmskh, gaus,blno, blto
7976 &, outlat, outlon, me)
7977 elseif (fnaisc(1:8).ne.' ') then
7978 call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmskw,
7979 & ais(1,nn),len,iret
7980 &, imsk, jmsk, slmskh, gaus,blno, blto
7981 &, outlat, outlon, me)
7982 else
7983 write(6,*) 'FATAL ERROR: climatological ice cover'
7984 write(6,*) 'file not given.'
7985 call abort
7986 endif
7987!
7988! snow depth
7989!
7990 kpd7=-1
7991 call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmskl,
7992 & sno(1,nn),len,iret
7993 &, imsk, jmsk, slmskh, gaus,blno, blto
7994 &, outlat, outlon, me)
7995!
7996! snow cover
7997!
7998 if (fnscvc(1:8).ne.' ') then
7999 kpd7=-1
8000 call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmskl,
8001 & scv(1,nn),len,iret
8002 &, imsk, jmsk, slmskh, gaus,blno, blto
8003 &, outlat, outlon, me)
8004 write(6,*) 'climatological snow cover read in.'
8005 endif
8006!
8007! surface roughness
8008!
8009 if (fnzorc(1:3) == 'sib') then
8010 if (me == 0) then
8011 write(6,*) 'roughness length to be set from sib veg type'
8012 endif
8013 elseif(fnzorc(1:4) == 'igbp') then
8014 if (me == 0) then
8015 write(6,*) 'roughness length to be set from igbp veg type'
8016 endif
8017 else
8018 kpd7=-1
8019 call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmskl,
8020 & zor(1,nn),len,iret
8021 &, imsk, jmsk, slmskh, gaus,blno, blto
8022 &, outlat, outlon, me)
8023 endif
8024!
8025! vegetation cover
8026!
8027 if (fnvegc(1:8) .ne. ' ') then
8028 if ( index(fnvegc, "tileX.nc") == 0) then ! grib file
8029 kpd7=-1
8030 call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmskl,
8031 & veg(1,nn),len,iret
8032 &, imsk, jmsk, slmskh, gaus,blno, blto
8033 &, outlat, outlon, me)
8034 else
8035 call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index,
8036 & kpdveg, veg(:,nn), mon, len, me)
8037 endif
8038! if (me .eq. 0) write(6,*) 'climatological vegetation',
8039! & ' cover read in for mon=',mon
8040 endif
8041!
8042 endif
8043!
8044! now perform the time interpolation
8045!
8046! when chosen, set the z0 based on the vegetation type.
8047! for this option to work, namelist variable fnvetc must be
8048! set to point at the proper vegetation type file.
8049 if (fnzorc(1:3) == 'sib') then
8050 if (fnvetc(1:4) == ' ') then
8051 if (me==0) then
8052 write(6,*) "FATAL ERROR: must choose sib"
8053 write(6,*) "vegetation type climo file."
8054 endif
8055 call abort
8056 endif
8057 zorclm = 0.0
8058 do i=1,len
8059 ivtyp = nint(vet(i))
8060 if (ivtyp >= 1 .and. ivtyp <= 13) then
8061 zorclm(i) = z0_sib(ivtyp)
8062 endif
8063 enddo
8064 elseif(fnzorc(1:4) == 'igbp') then
8065 if (fnvetc(1:4) == ' ') then
8066 if (me == 0) then
8067 write(6,*) "FATAL ERROR: must choose igbp"
8068 write(6,*) "vegetation type climo file."
8069 endif
8070 call abort
8071 endif
8072 zorclm = 0.0
8073 do i=1,len
8074 ivtyp = nint(vet(i))
8075 if (ivtyp >= 1 .and. ivtyp <= 20) then
8076 z0_season(1) = z0_igbp_min(ivtyp)
8077 z0_season(7) = z0_igbp_max(ivtyp)
8078 if (outlat(i) < 0.0) then
8079 zorclm(i) = wei1y * z0_season(hyr2) +
8080 & wei2y * z0_season(hyr1)
8081 else
8082 zorclm(i) = wei1y * z0_season(hyr1) +
8083 & wei2y * z0_season(hyr2)
8084 endif
8085 endif
8086 enddo
8087 else
8088 do i=1,len
8089 zorclm(i) = wei1m * zor(i,k1) + wei2m * zor(i,k2)
8090 enddo
8091 endif
8092!
8093 do i=1,len
8094 tsfclm(i) = wei1m * tsf(i,k1) + wei2m * tsf(i,k2)
8095 snoclm(i) = wei1m * sno(i,k1) + wei2m * sno(i,k2)
8096 cvclm(i) = 0.0
8097 cvbclm(i) = 0.0
8098 cvtclm(i) = 0.0
8099 cnpclm(i) = 0.0
8100 tsfcl2(i) = tsf2(i)
8101 enddo
8102! if(lprnt) print *,' tsfclm=',tsfclm(iprnt),' wei1m=',wei1m
8103! &,' wei2m=',wei2m,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2)
8104!
8105 if (fh .eq. 0.0) then
8106 do i=1,len
8107 tsfcl0(i) = tsfclm(i)
8108 enddo
8109 endif
8110 if (rjdayh .ge. dayhf(mon1)) then
8111 do i=1,len
8112 tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2)
8113 tsfcl2(i) = tsf2(i)
8114 enddo
8115 endif
8116! if(lprnt) print *,' tsf2=',tsf2(iprnt),' wei1x=',wei1x
8117! &,' wei2x=',wei2x,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2)
8118! &,' mon1s=',mon1s,' mon2s=',mon2s
8119! &,' slmask=',slmask(iprnt)
8120!
8121 if(fnacnc(1:8).ne.' ') then
8122 do i=1,len
8123 acnclm(i) = wei1m * acn(i,k1) + wei2m * acn(i,k2)
8124 enddo
8125 elseif(fnaisc(1:8).ne.' ') then
8126 do i=1,len
8127 aisclm(i) = wei1m * ais(i,k1) + wei2m * ais(i,k2)
8128 enddo
8129 endif
8130!
8131 if(fnwetc(1:8).ne.' ') then
8132 do i=1,len
8133 wetclm(i) = wei1m * wet(i,k1) + wei2m * wet(i,k2)
8134 enddo
8135 elseif(fnsmcc(1:8).ne.' ') then
8136 do k=1,lsoil
8137 do i=1,len
8138 smcclm(i,k) = wei1m * smc(i,k,k1) + wei2m * smc(i,k,k2)
8139 enddo
8140 enddo
8141 endif
8142!
8143 if(fnscvc(1:8).ne.' ') then
8144 do i=1,len
8145 scvclm(i) = wei1m * scv(i,k1) + wei2m * scv(i,k2)
8146 enddo
8147 endif
8148!
8149 if(fntg3c(1:8).ne.' ') then
8150 do i=1,len
8151 tg3clm(i) = tg3(i)
8152 enddo
8153 elseif(fnstcc(1:8).ne.' ') then
8154 do k=1,lsoil
8155 do i=1,len
8156 stcclm(i,k) = wei1m * stc(i,k,k1) + wei2m * stc(i,k,k2)
8157 enddo
8158 enddo
8159 endif
8160!
8161 if(fnvegc(1:8).ne.' ') then
8162 do i=1,len
8163 vegclm(i) = wei1m * veg(i,k1) + wei2m * veg(i,k2)
8164 enddo
8165 endif
8166!
8167 if(fnvetc(1:8).ne.' ') then
8168 do i=1,len
8169 vetclm(i) = vet(i)
8170 enddo
8171 endif
8172!
8173 if(fnsotc(1:8).ne.' ') then
8174 do i=1,len
8175 sotclm(i) = sot(i)
8176 enddo
8177 endif
8178
8179! initialize socclm in case there is no soil color data input
8180
8181 do i=1,len
8182 socclm(i) = 4.
8183 enddo
8184
8185 if(fnsocc(1:8).ne.' ') then
8186 do i=1,len
8187 socclm(i) = soc(i)
8188 enddo
8189 endif
8190
8191!clu ----------------------------------------------------------------------
8192!
8193 if(fnvmnc(1:8).ne.' ') then
8194 do i=1,len
8195 vmnclm(i) = vmn(i)
8196 enddo
8197 endif
8198!
8199 if(fnvmxc(1:8).ne.' ') then
8200 do i=1,len
8201 vmxclm(i) = vmx(i)
8202 enddo
8203 endif
8204!
8205 if(fnslpc(1:8).ne.' ') then
8206 do i=1,len
8207 slpclm(i) = slp(i)
8208 enddo
8209 endif
8210!
8211 if(fnabsc(1:8).ne.' ') then
8212 do i=1,len
8213 absclm(i) = absm(i)
8214 enddo
8215 endif
8216!clu ----------------------------------------------------------------------
8217!
8218!cbosu diagnostic print
8219 if (me == 0) print*,'monthly albedo weights are ',
8220 & wei1m,' for k', k1, wei2m, ' for k', k2
8221
8222 if (ialb == 1 .or. ialb == 2) then
8223 do k=1,4
8224 do i=1,len
8225 albclm(i,k) = wei1m * alb(i,k,k1) + wei2m * alb(i,k,k2)
8226 enddo
8227 enddo
8228 else
8229 do k=1,4
8230 do i=1,len
8231 albclm(i,k) = wei1s * alb(i,k,m1) + wei2s * alb(i,k,m2)
8232 enddo
8233 enddo
8234 endif
8235!
8236 do k=1,2
8237 do i=1,len
8238 alfclm(i,k) = alf(i,k)
8239 enddo
8240 enddo
8241!
8242! end of climatology reads
8243!
8244 return
8245 end subroutine clima
8246
8248 subroutine fixrdc_tile(filename_raw, tile_num_ch, &
8249 & i_index, j_index, kpds, var, mon, npts, me)
8250 use netcdf
8251 use machine , only : kind_io8
8252 implicit none
8253 character(len=*), intent(in) :: filename_raw
8254 character(len=*), intent(in) :: tile_num_ch
8255 integer, intent(in) :: npts, me, kpds, mon
8256 integer, intent(in) :: i_index(npts)
8257 integer, intent(in) :: j_index(npts)
8258 real(kind_io8), intent(out) :: var(npts)
8259 character(len=500) :: filename
8260 character(len=80) :: errmsg
8261 integer :: i, ii, ncid, t
8262 integer :: error, id_dim
8263 integer :: nx, ny, num_times
8264 integer :: id_var
8265 real(kind=4), allocatable :: dummy(:,:,:)
8266
8267 ii = index(filename_raw,"tileX")
8268
8269 do i = 1, len(filename)
8270 filename(i:i) = " "
8271 enddo
8272
8273 filename = filename_raw(1:ii-1) // tile_num_ch // ".nc"
8274
8275 if (me == 0) print*, ' in fixrdc_tile for mon=',mon,
8276 & ' filename=', trim(filename)
8277
8278 error=nf90_open(trim(filename), nf90_nowrite, ncid)
8279 if (error /= nf90_noerr) call netcdf_err(error)
8280
8281 error=nf90_inq_dimid(ncid, 'nx', id_dim)
8282 if (error /= nf90_noerr) call netcdf_err(error)
8283 error=nf90_inquire_dimension(ncid,id_dim,len=nx)
8284 if (error /= nf90_noerr) call netcdf_err(error)
8285
8286 error=nf90_inq_dimid(ncid, 'ny', id_dim)
8287 if (error /= nf90_noerr) call netcdf_err(error)
8288 error=nf90_inquire_dimension(ncid,id_dim,len=ny)
8289 if (error /= nf90_noerr) call netcdf_err(error)
8290
8291 error=nf90_inq_dimid(ncid, 'time', id_dim)
8292 if (error /= nf90_noerr) call netcdf_err(error)
8293 error=nf90_inquire_dimension(ncid,id_dim,len=num_times)
8294 if (error /= nf90_noerr) call netcdf_err(error)
8295
8296 select case (kpds)
8297 case(11)
8298 error=nf90_inq_varid(ncid, 'substrate_temperature', id_var)
8299 case(87)
8300 error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var)
8301 case(159)
8302 error=nf90_inq_varid(ncid, 'maximum_snow_albedo', id_var)
8303 case(189)
8304 error=nf90_inq_varid(ncid, 'visible_black_sky_albedo', id_var)
8305 case(190)
8306 error=nf90_inq_varid(ncid, 'visible_white_sky_albedo', id_var)
8307 case(191)
8308 error=nf90_inq_varid(ncid, 'near_IR_black_sky_albedo', id_var)
8309 case(192)
8310 error=nf90_inq_varid(ncid, 'near_IR_white_sky_albedo', id_var)
8311 case(214)
8312 error=nf90_inq_varid(ncid, 'facsf', id_var)
8313 case(224)
8314 error=nf90_inq_varid(ncid, 'soil_type', id_var)
8315 case(225)
8316 error=nf90_inq_varid(ncid, 'vegetation_type', id_var)
8317 case(236)
8318 error=nf90_inq_varid(ncid, 'slope_type', id_var)
8319 case(255)
8320 error=nf90_inq_varid(ncid, 'soil_color', id_var)
8321 case(256:257)
8322 error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var)
8323 case default
8324 print*,'FATAL ERROR in fixrdc_tile of sfcsub.F.'
8325 print*,'Unknown variable.'
8326 call abort
8327 end select
8328 if (error /= nf90_noerr) call netcdf_err(error)
8329
8330 allocate(dummy(nx,ny,1))
8331
8332 if (kpds == 256) then ! max veg greenness
8333
8334 var = -9999.
8335 do t = 1, num_times
8336 error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/),
8337 & count=(/nx,ny,1/) )
8338 if (error /= nf90_noerr) call netcdf_err(error)
8339 do ii = 1,npts
8340 var(ii) = max(var(ii), dummy(i_index(ii),j_index(ii),1))
8341 enddo
8342 enddo
8343
8344 elseif (kpds == 257) then ! min veg greenness
8345
8346 var = 9999.
8347 do t = 1, num_times
8348 error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/),
8349 & count=(/nx,ny,1/) )
8350 if (error /= nf90_noerr) call netcdf_err(error)
8351 do ii = 1, npts
8352 var(ii) = min(var(ii), dummy(i_index(ii),j_index(ii),1))
8353 enddo
8354 enddo
8355
8356 else
8357
8358 error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,mon/),
8359 & count=(/nx,ny,1/) )
8360 if (error /= nf90_noerr) call netcdf_err(error)
8361
8362 do ii = 1, npts
8363 var(ii) = dummy(i_index(ii),j_index(ii),1)
8364 enddo
8365
8366 endif
8367
8368 deallocate(dummy)
8369
8370 error=nf90_close(ncid)
8371
8372 select case (kpds)
8373 case(159) ! max snow alb
8374 var = var * 100.0
8375 case(214) ! facsf
8376 where (var < 0.0) var = 0.0
8377 var = var * 100.0
8378 case(189:192)
8379 var = var * 100.0
8380 case(256:257)
8381 var = var * 100.0
8382 end select
8383
8384 return
8385
8386 end subroutine fixrdc_tile
8387
8389 subroutine netcdf_err(error)
8390
8391 use netcdf
8392 implicit none
8393
8394 integer,intent(in) :: error
8395 character(len=256) :: errmsg
8396
8397 errmsg = nf90_strerror(error)
8398 print*,'FATAL ERROR in sfcsub.F: ', trim(errmsg)
8399 call abort
8400
8401 end subroutine netcdf_err
8402
8407 subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, &
8408 & gdata,len,iret &
8409 &, imsk, jmsk, slmskh, gaus,blno, blto &
8410 &, outlat, outlon, me)
8411 use machine , only : kind_io8,kind_dbl_prec,kind_sngl_prec
8412 use sfccyc_module, only : mdata
8413 implicit none
8414 integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, &
8415 & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami &
8416 &, jj
8417 real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto
8418!
8419!
8420 character*500 fngrib
8421! character*80 fngrib, asgnstr
8422!
8423 real (kind=kind_io8) slmskh(imsk,jmsk)
8424!
8425 real (kind=kind_io8) gdata(len), slmask(len)
8426 real (kind=kind_io8), allocatable :: data(:,:), rslmsk(:,:)
8427 real (kind=kind_dbl_prec), allocatable :: data8(:)
8428 real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:)
8429!
8430 logical lmask, yr2kc, gaus, ijordr
8431 logical*1, allocatable :: lbms(:)
8432!
8433 integer, intent(in) :: kpds7
8434 integer kpds(1000),kgds(1000)
8435 integer jpds(1000),jgds(1000), kpds0(1000)
8436 real (kind=kind_io8) outlat(len), outlon(len)
8437!
8438 allocate(data8(1:mdata))
8439 allocate(lbms(mdata))
8440!
8441! integer imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv
8442! date imax_sv/0/, jmax_sv/0/, wlon_sv/999.0/, rnlat_sv/999.0/
8443! &, kpds1_sv/-1/
8444! save imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv
8445! &, rlngrb, rltgrb
8446!
8447 iret = 0
8448!
8449 if (me .eq. 0) write(6,*) ' in fixrdc for mon=',mon
8450 &,' fngrib=',trim(fngrib)
8451!
8452 close(lugb)
8453 call baopenr(lugb,fngrib,iret)
8454 if (iret .ne. 0) then
8455 write(6,*) ' FATAL ERROR: in opening file ',trim(fngrib)
8456 print *,'FATAL ERROR: in opening file ',trim(fngrib)
8457 call abort
8458 endif
8459 if (me .eq. 0) write(6,*) ' file ',trim(fngrib),
8460 & ' opened. unit=',lugb
8461!
8462 lugi = 0
8463!
8464 lskip = -1
8465 jpds = -1
8466 jgds = -1
8467 jpds(5) = kpds5
8468 jpds(7) = kpds7
8469 kpds = jpds
8470 call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata,
8471 & lskip,kpds,kgds,iret)
8472 if (me .eq. 0) then
8473 write(6,*) ' first grib record.'
8474 write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10)
8475 write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20)
8476 write(6,*) ' kpds(21- )=',(kpds(j),j=21,22)
8477 endif
8478 yr2kc = (kpds(8) / 100) .gt. 0
8479 kpds0 = jpds
8480 kpds0(4) = -1
8481 kpds0(18) = -1
8482 if(iret.ne.0) then
8483 write(6,*) ' FATAL ERROR: in getgbh. iret: ', iret
8484 if (iret==99) write(6,*) ' Field not found.'
8485 call abort
8486 endif
8487!
8488! handling climatology file
8489!
8490 lskip = -1
8491 n = 0
8492 jpds = kpds0
8493 jpds(9) = mon
8494 if(jpds(9).eq.13) jpds(9) = 1
8495 call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip,
8496 & kpds,kgds,lbms,data8,jret)
8497 if (me .eq. 0) write(6,*) ' input grib file dates=',
8498 & (kpds(i),i=8,11)
8499 if(jret.eq.0) then
8500 if(ndata.eq.0) then
8501 write(6,*) ' FATAL ERROR: in getgb'
8502 write(6,*) ' kpds=',kpds
8503 write(6,*) ' kgds=',kgds
8504 call abort
8505 endif
8506 imax=kgds(2)
8507 jmax=kgds(3)
8508 ijmax=imax*jmax
8509 allocate (data(imax,jmax))
8510 do j=1,jmax
8511 jj = (j-1)*imax
8512 do i=1,imax
8513 data(i,j) = data8(jj+i)
8514 enddo
8515 enddo
8516 if (me .eq. 0) write(6,*) 'imax,jmax,ijmax=',imax,jmax,ijmax
8517 else
8518 write(6,*) ' FATAL ERROR: in getgb - jret=', jret
8519 call abort
8520 endif
8521!
8522! if (me == 0) then
8523! write(6,*) ' maxmin of input as is'
8524! kmami=1
8525! call maxmin(data(1,1),ijmax,kmami)
8526! endif
8527!
8528 call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me)
8529 if (me == 0) then
8530 write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat='
8531 write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat
8532 endif
8533 call subst(data,imax,jmax,dlon,dlat,ijordr)
8534!
8535! first get slmask over input grid
8536!
8537 allocate (rlngrb(imax), rltgrb(jmax))
8538 allocate (rslmsk(imax,jmax))
8539
8540 call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat,
8541 & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk
8542 &, gaus,blno, blto, kgds(1), kpds(4), lbms)
8543! write(6,*) ' kpds5=',kpds5,' lmask=',lmask
8544!
8545 inttyp = 0
8546 if(kpds5.eq.225) inttyp = 1
8547 if(kpds5.eq.230) inttyp = 1
8548 if(kpds5.eq.236) inttyp = 1
8549 if(kpds5.eq.224) inttyp = 1
8550 if (me .eq. 0) then
8551 if(inttyp.eq.1) print *, ' nearest grid point used'
8552 &, ' kpds5=',kpds5, ' lmask = ',lmask
8553 endif
8554!
8555 call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp,
8556 & gdata,len,lmask,rslmsk,slmask
8557 &, outlat, outlon,me)
8558!
8559 deallocate (rlngrb, stat=iret)
8560 deallocate (rltgrb, stat=iret)
8561 deallocate (data, stat=iret)
8562 deallocate (rslmsk, stat=iret)
8563 call baclose(lugb,iret)
8564!
8565 deallocate(data8)
8566 deallocate(lbms)
8567 return
8568 end subroutine fixrdc
8569
8571 subroutine fixrda(lugb,fngrib,kpds5,slmask, &
8572 & iy,im,id,ih,fh,gdata,len,iret &
8573 &, imsk, jmsk, slmskh, gaus,blno, blto &
8574 &, outlat, outlon, me)
8575 use machine , only : kind_io8,kind_dbl_prec,kind_sngl_prec
8576 use sfccyc_module, only : mdata
8577 implicit none
8578 integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, &
8579 & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, &
8580 & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, &
8581 & monend,jy,iy4,kmami,iret2,jj
8582 real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, &
8583 & rjday,blto
8584!
8585! read in grib climatology/analysis files and interpolate to the input
8586! dates and the grid. grib files should allow all the necessary parameters
8587! to be extracted from the description records.
8588!
8589! nrepmx: max number of days for going back date search
8590! nvalid: analysis later than (current date - nvalid) is regarded as
8591! valid for current analysis
8592!
8593 parameter(nrepmx=15, nvalid=4)
8594!
8595 character*500 fngrib
8596! character*80 fngrib, asgnstr
8597!
8598 real (kind=kind_io8) slmskh(imsk,jmsk)
8599!
8600 real (kind=kind_io8) gdata(len), slmask(len)
8601 real (kind=kind_io8), allocatable :: data(:,:),rslmsk(:,:)
8602 real (kind=kind_dbl_prec), allocatable :: data8(:)
8603 real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:)
8604!
8605 logical lmask, yr2kc, gaus, ijordr
8606 logical*1 lbms(mdata)
8607!
8608 integer kpds(1000),kgds(1000)
8609 integer jpds(1000),jgds(1000), kpds0(1000)
8610 real (kind=kind_io8) outlat(len), outlon(len)
8611!
8612! dayhf : julian day of the middle of each month
8613!
8614 real (kind=kind_io8) dayhf(13)
8615 data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0,
8616 & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/
8617!
8618! mjday : number of days in a month
8619!
8620 integer mjday(12)
8621 data mjday/31,28,31,30,31,30,31,31,30,31,30,31/
8622!
8623 real (kind=kind_dbl_prec) fha(5)
8624 integer ida(8),jda(8)
8625!
8626 allocate(data8(1:mdata))
8627 iret = 0
8628 monend = 9999
8629!
8630! compute jy,jm,jd,jh of forecast and the day of the year
8631!
8632 iy4=iy
8633 if(iy.lt.101) iy4=1900+iy4
8634 fha=0
8635 ida=0
8636 jda=0
8637 fha(2)=nint(fh)
8638 ida(1)=iy
8639 ida(2)=im
8640 ida(3)=id
8641 ida(5)=ih
8642 call w3movdat(fha,ida,jda)
8643 jy=jda(1)
8644 jm=jda(2)
8645 jd=jda(3)
8646 jh=jda(5)
8647! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=',
8648! & jy,jm,jd,jh,rjday
8649 jdow = 0
8650 jdoy = 0
8651 jday = 0
8652 call w3doxdat(jda,jdow,jdoy,jday)
8653 rjday=jdoy+jda(5)/24.
8654 if(rjday.lt.dayhf(1)) rjday=rjday+365.
8655
8656 if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=',
8657 & jy,jm,jd,jh,rjday
8658!
8659 if (me .eq. 0) then
8660 write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh
8661!
8662 write(6,*) ' '
8663 write(6,*) '************************************************'
8664 endif
8665!
8666 close(lugb)
8667 call baopenr(lugb,fngrib,iret)
8668 if (iret .ne. 0) then
8669 write(6,*) ' FATAL ERROR: in opening file ',trim(fngrib)
8670 print *,'FATAL ERROR in opening file ',trim(fngrib)
8671 call abort
8672 endif
8673 if (me .eq. 0) write(6,*) ' file ',trim(fngrib),
8674 & ' opened. unit=',lugb
8675!
8676 lugi = 0
8677!
8678 lskip=-1
8679 jpds=-1
8680 jgds=-1
8681 jpds(5)=kpds5
8682 kpds = jpds
8683 call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata,
8684 & lskip,kpds,kgds,iret)
8685 if (me .eq. 0) then
8686 write(6,*) ' first grib record.'
8687 write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10)
8688 write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20)
8689 write(6,*) ' kpds(21- )=',(kpds(j),j=21,22)
8690 endif
8691 yr2kc = (kpds(8) / 100) .gt. 0
8692 kpds0=jpds
8693 kpds0(4)=-1
8694 kpds0(18)=-1
8695 if(iret.ne.0) then
8696 write(6,*) ' FATAL ERROR: in getgbh. iret: ', iret
8697 if(iret==99) write(6,*) ' Field not found.'
8698 call abort
8699 endif
8700!
8701! handling analysis file
8702!
8703! find record for the given hour/day/month/year
8704!
8705 nrept=0
8706 jpds=kpds0
8707 lskip = -1
8708 iyr=jy
8709 if(iyr.le.100) iyr=2050-mod(2050-iyr,100)
8710 imo=jm
8711 idy=jd
8712 ihr=jh
8713! year 2000 compatible data
8714 if (yr2kc) then
8715 jpds(8) = iyr
8716 else
8717 jpds(8) = mod(iyr,1900)
8718 endif
8719 50 continue
8720 jpds( 8)=mod(iyr-1,100)+1
8721 jpds( 9)=imo
8722 jpds(10)=idy
8723! jpds(11)=ihr
8724 jpds(21)=(iyr-1)/100+1
8725 call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip,
8726 & kpds,kgds,lbms,data8,jret)
8727 if (me .eq. 0) write(6,*) ' input grib file dates=',
8728 & (kpds(i),i=8,11)
8729 if(jret.eq.0) then
8730 if(ndata.eq.0) then
8731 write(6,*) ' FATAL ERROR: in getgb'
8732 write(6,*) ' kpds=',kpds
8733 write(6,*) ' kgds=',kgds
8734 call abort
8735 endif
8736 imax=kgds(2)
8737 jmax=kgds(3)
8738 ijmax=imax*jmax
8739 allocate (data(imax,jmax))
8740 do j=1,jmax
8741 jj = (j-1)*imax
8742 do i=1,imax
8743 data(i,j) = data8(jj+i)
8744 enddo
8745 enddo
8746 else
8747 if(nrept.eq.0) then
8748 if (me .eq. 0) then
8749 write(6,*) ' no matching dates found. start searching',
8750 & ' nearest matching dates (going back).'
8751 endif
8752 endif
8753!
8754! no matching ih found. search nearest hour
8755!
8756 if(ihr.eq.6) then
8757 ihr=0
8758 go to 50
8759 elseif(ihr.eq.12) then
8760 ihr=0
8761 go to 50
8762 elseif(ihr.eq.18) then
8763 ihr=12
8764 go to 50
8765 elseif(ihr.eq.0.or.ihr.eq.-1) then
8766 idy=idy-1
8767 if(idy.eq.0) then
8768 imo=imo-1
8769 if(imo.eq.0) then
8770 iyr=iyr-1
8771 if(iyr.lt.0) iyr=99
8772 imo=12
8773 endif
8774 idy=31
8775 if(imo.eq.4.or.imo.eq.6.or.imo.eq.9.or.imo.eq.11) idy=30
8776 if(imo.eq.2) then
8777 if(mod(iyr,4).eq.0) then
8778 idy=29
8779 else
8780 idy=28
8781 endif
8782 endif
8783 endif
8784 ihr=-1
8785 if (me .eq. 0) write(6,*) ' decremented dates=',
8786 & iyr,imo,idy,ihr
8787 nrept=nrept+1
8788 if(nrept.gt.nvalid) iret=-1
8789 if(nrept.gt.nrepmx) then
8790 if (me .eq. 0) then
8791 write(6,*) ' <warning:cycl> searching range exceeded.'
8792 &, ' may be wrong grib file given'
8793 write(6,*) ' <warning:cycl> fngrib=',trim(fngrib)
8794 write(6,*) ' <warning:cycl> terminating search and',
8795 & ' and setting gdata to -999'
8796 write(6,*) ' range max=',nrepmx
8797 endif
8798! imax=kgds(2)
8799! jmax=kgds(3)
8800! ijmax=imax*jmax
8801! do ij=1,ijmax
8802! data(ij)=0.
8803! enddo
8804 go to 100
8805 endif
8806 go to 50
8807 else
8808 if (me .eq. 0) then
8809 write(6,*) ' search of analysis for ihr=',ihr,' failed.'
8810 write(6,*) ' kpds=',kpds
8811 write(6,*) ' iyr,imo,idy,ihr=',iyr,imo,idy,ihr
8812 endif
8813 go to 100
8814 endif
8815 endif
8816!
8817 80 continue
8818! if (me == 0) then
8819! write(6,*) ' maxmin of input as is'
8820! kmami=1
8821! call maxmin(data(1,1),ijmax,kmami)
8822! endif
8823!
8824 call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me)
8825 if (me == 0) then
8826 write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat='
8827 write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat
8828 endif
8829 call subst(data,imax,jmax,dlon,dlat,ijordr)
8830!
8831! first get slmask over input grid
8832!
8833 allocate (rlngrb(imax), rltgrb(jmax))
8834 allocate (rslmsk(imax,jmax))
8835 call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat,
8836 & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk
8837! & data,imax,jmax,abs(dlon),abs(dlat),lmask,rslmsk
8838!cggg &, gaus,blno, blto, kgds(1))
8839 &, gaus,blno, blto, kgds(1), kpds(4), lbms)
8840
8841! write(6,*) ' kpds5=',kpds5,' lmask=',lmask
8842!
8843 inttyp = 0
8844 if(kpds5.eq.225) inttyp = 1
8845 if(kpds5.eq.230) inttyp = 1
8846 if(kpds5.eq.66) inttyp = 1
8847 if(inttyp.eq.1) print *, ' nearest grid point used'
8848!
8849 call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp,
8850 & gdata,len,lmask,rslmsk,slmask
8851 &, outlat, outlon, me)
8852!
8853 deallocate (rlngrb, stat=iret)
8854 deallocate (rltgrb, stat=iret)
8855 deallocate (data, stat=iret)
8856 deallocate (rslmsk, stat=iret)
8857 call baclose(lugb,iret2)
8858! write(6,*) ' '
8859 deallocate(data8)
8860 return
8861!
8862 100 continue
8863 iret=1
8864 do i=1,len
8865 gdata(i) = -999.
8866 enddo
8867!
8868 call baclose(lugb,iret2)
8869!
8870 deallocate(data8)
8871 return
8872 end subroutine fixrda
8873
8875 subroutine snodpth2(glacir,snwmax,snoanl, len, me)
8876 use machine , only : kind_io8,kind_io4
8877 implicit none
8878 integer i,me,len
8879 real (kind=kind_io8) snwmax
8880!
8881 real (kind=kind_io8) snoanl(len), glacir(len)
8882!
8883 if (me .eq. 0) write(6,*) 'snodpth2'
8884!
8885 do i=1,len
8886!
8887! if glacial points has snow in climatology, set sno to snomax
8888!
8889 if(glacir(i).ne.0..and.snoanl(i).lt.snwmax*0.5) then
8890 snoanl(i) = snwmax + snoanl(i)
8891 endif
8892!
8893 enddo
8894 return
8895 end
8896
subroutine sfccycle(lugb, len, lsoil, sig1t, deltsfc, iy, im, id, ih, fh, rla, rlo, slmskl, slmskw, orog, orog_uf, use_ufo, nst_anl, sihfcs, sicfcs, sitfcs, swdfcs, slcfcs, vmnfcs, vmxfcs, slpfcs, absfcs, tsffcs, snofcs, zorfcs, albfcs, tg3fcs, cnpfcs, smcfcs, stcfcs, slifcs, aisfcs, vegfcs, vetfcs, sotfcs, socfcs, alffcs, cvfcs, cvbfcs, cvtfcs, me, nthrds, nlunit, sz_nml, input_nml_file, min_ice, ialb, isot, ivegsrc, tile_num_ch, i_index, j_index)
This subroutine reads or interpolates surface climatology data in analysis and forecast mode.
Definition sfcsub.F:90
integer, parameter ydata
Definition sfcsub.F:37
subroutine getstc(tsffld, tg3fld, slifld, len, lsoil, stcfld, tsfimx)
Definition sfcsub.F:5946
subroutine tsfcor(tsfc, orog, slmask, umask, len, rlapse)
Definition sfcsub.F:4692
integer veg_type_landice
Definition sfcsub.F:38
subroutine fixrda(lugb, fngrib, kpds5, slmask, iy, im, id, ih, fh, gdata, len, iret, imsk, jmsk, slmskh, gaus, blno, blto, outlat, outlon, me)
Definition sfcsub.F:8575
subroutine monitr(lfld, fld, slimsk, sno, ijmax)
Definition sfcsub.F:2685
subroutine maxmin(f, imax, kmax)
Definition sfcsub.F:3660
subroutine qcsli(slianl, slifcs, len, me)
Definition sfcsub.F:6093
subroutine getsmc(wetfld, len, lsoil, smcfld, me)
This subroutine calculates layer soil wetness.
Definition sfcsub.F:5982
subroutine snodpth2(glacir, snwmax, snoanl, len, me)
Definition sfcsub.F:8876
integer, dimension(4), parameter kpdalb_0
Definition sfcsub.F:32
subroutine anomint(tsfan0, tsfclm, tsfcl0, tsfanl, len)
The subroutine conducts time interpolation of anomalies, and add initial anomaly to date interpolated...
Definition sfcsub.F:7034
subroutine fixrdg(lugb, idim, jdim, fngrib, kpds5, gdata, gaus, blno, blto, me)
Definition sfcsub.F:2804
subroutine getarea(kgds, dlat, dlon, rslat, rnlat, wlon, elon, ijordr, me)
This subroutine get area of the grib record.
Definition sfcsub.F:2908
integer soil_color_landice
Definition sfcsub.F:40
subroutine albocn(albclm, slmask, albomx, len)
Definition sfcsub.F:6053
subroutine rof01(aisfld, len, op, crit)
Definition sfcsub.F:4594
real(kind=kind_io8), parameter one
Definition sfcsub.F:36
subroutine setzro(fld, eps, len)
Definition sfcsub.F:5918
subroutine qcmxice(glacir, amxice, len, me)
Definition sfcsub.F:6071
integer kpdgla
Definition sfcsub.F:17
subroutine snosfc(snoanl, tsfanl, tsfsmx, len, me)
Definition sfcsub.F:6027
subroutine rof01_len(aisfld, len, op, crit)
Definition sfcsub.F:4643
subroutine setlsi(slmask, aisfld, len, aicice, slifld)
Definition sfcsub.F:5475
integer kpdzor
Definition sfcsub.F:17
integer num_threads
Definition sfcsub.F:41
integer soil_type_landice
Definition sfcsub.F:39
subroutine subst(data, imax, jmax, dlon, dlat, ijordr)
Definition sfcsub.F:3059
subroutine fixrdc(lugb, fngrib, kpds5, kpds7, mon, slmask, gdata, len, iret, imsk, jmsk, slmskh, gaus, blno, blto, outlat, outlon, me)
reads in grib climatology files and interpolate to the input grid. grib files should allow all the ne...
Definition sfcsub.F:8411
real(kind=kind_io8), parameter ten
Definition sfcsub.F:36
subroutine bktges(smcfcs, stcfcs, len, lsoil)
Definition sfcsub.F:4565
integer kpdsno
Definition sfcsub.F:17
subroutine qcmxmn(ttl, fld, slimsk, sno, iceflg, fldlmx, fldlmn, fldomx, fldomn, fldimx, fldimn, fldjmx, fldjmn, fldsmx, fldsmn, epsfld, rla, rlo, len, mode, percrit, lgchek, me)
Definition sfcsub.F:5509
subroutine merge(len, lsoil, iy, im, id, ih, fh, deltsfc, slmskl, slmskw, sihfcs, sicfcs, vmnfcs, vmxfcs, slpfcs, absfcs, tsffcs, wetfcs, snofcs, zorfcs, albfcs, aisfcs, cvfcs, cvbfcs, cvtfcs, cnpfcs, smcfcs, stcfcs, slifcs, vegfcs, vetfcs, sotfcs, socfcs, alffcs, sihanl, sicanl, vmnanl, vmxanl, slpanl, absanl, tsfanl, tsfan2, wetanl, snoanl, zoranl, albanl, aisanl, cvanl, cvbanl, cvtanl, cnpanl, smcanl, stcanl, slianl, veganl, vetanl, sotanl, socanl, alfanl, ctsfl, calbl, caisl, csnol, csmcl, czorl, cstcl, cvegl, ctsfs, calbs, caiss, csnos, csmcs, czors, cstcs, cvegs, ccv, ccvb, ccvt, ccnp, cvetl, cvets, csotl, csots, csocl, csocs, calfl, calfs, csihl, csihs, csicl, csics, cvmnl, cvmns, cvmxl, cvmxs, cslpl, cslps, cabsl, cabss, irttsf, irtwet, irtsno, irtzor, irtalb, irtais, irttg3, irtscv, irtacn, irtsmc, irtstc, irtveg, irtvmn, irtvmx, irtslp, irtabs, irtvet, irtsot, irtsoc, irtalf, landice, me)
This subroutine merges analysis and forecast.
Definition sfcsub.F:4790
subroutine setrmsk(kpds5, slmask, igaul, jgaul, wlon, rnlat, data, imax, jmax, rlnout, rltout, lmask, rslmsk, gaus, blno, blto, kgds1, kpds4, lbms)
Definition sfcsub.F:6256
subroutine count(slimsk, sno, ijmax)
This subroutine counts number of points for the four surface conditions.
Definition sfcsub.F:2631
subroutine qcsnow(snoanl, slmask, aisanl, glacir, len, snoval, landice, me)
Definition sfcsub.F:5326
subroutine clima(lugb, iy, im, id, ih, fh, len, lsoil, slmskl, slmskw, fntsfc, fnwetc, fnsnoc, fnzorc, fnalbc, fnaisc, fntg3c, fnscvc, fnsmcc, fnstcc, fnacnc, fnvegc, fnvetc, fnsotc, fnsocc, fnvmnc, fnvmxc, fnslpc, fnabsc, tsfclm, tsfcl2, wetclm, snoclm, zorclm, albclm, aisclm, tg3clm, cvclm, cvbclm, cvtclm, cnpclm, smcclm, stcclm, sliclm, scvclm, acnclm, vegclm, vetclm, sotclm, socclm, alfclm, vmnclm, vmxclm, slpclm, absclm, kpdtsf, kpdwet, kpdsno, kpdzor, kpdalb, kpdais, kpdtg3, kpdscv, kpdacn, kpdsmc, kpdstc, kpdveg, kpdvet, kpdsot, kpdsoc, kpdalf, tsfcl0, kpdvmn, kpdvmx, kpdslp, kpdabs, deltsfc, lanom, imsk, jmsk, slmskh, outlat, outlon, gaus, blno, blto, me, lprnt, iprnt, fnalbc2, ialb, tile_num_ch, i_index, j_index)
Definition sfcsub.F:7070
integer kpdais
Definition sfcsub.F:17
subroutine getscv(snofld, scvfld, len)
Definition sfcsub.F:5931
integer, dimension(2), parameter kpdalf
Definition sfcsub.F:34
integer, parameter xdata
Definition sfcsub.F:37
real(kind=kind_io8), parameter zero
Definition sfcsub.F:36
character(len=16) function message(prefix, index)
Definition sfcsub.F:47
subroutine newice(slianl, slifcs, tsfanl, tsffcs, len, lsoil, sihnew, sicnew, sihanl, sicanl, albanl, snoanl, zoranl, smcanl, stcanl, albsea, snosea, zorsea, smcsea, smcice, tsfmin, tsfice, albice, zorice, tgice, rla, rlo, me)
Definition sfcsub.F:5233
integer, parameter mdata
Definition sfcsub.F:37
subroutine hmskrd(lugb, imsk, jmsk, fnmskh, kpds5, slmskh, gausm, blnmsk, bltmsk, me)
reads a high resolution mask field for use in grib interpolation
Definition sfcsub.F:2771
subroutine filanl(tsfanl, tsfan2, wetanl, snoanl, zoranl, albanl, aisanl, tg3anl, cvanl, cvbanl, cvtanl, cnpanl, smcanl, stcanl, slianl, scvanl, veganl, vetanl, sotanl, socanl, alfanl, sihanl, sicanl, vmnanl, vmxanl, slpanl, absanl, tsfclm, tsfcl2, wetclm, snoclm, zorclm, albclm, aisclm, tg3clm, cvclm, cvbclm, cvtclm, cnpclm, smcclm, stcclm, sliclm, scvclm, vegclm, vetclm, sotclm, socclm, alfclm, sihclm, sicclm, vmnclm, vmxclm, slpclm, absclm, len, lsoil)
Definition sfcsub.F:3708
subroutine netcdf_err(error)
Definition sfcsub.F:8390
subroutine landtyp(vegtype, soiltype, colortype, slptype, slmask, len)
Definition sfcsub.F:6987
subroutine la2ga(regin, imxin, jmxin, rinlon, rinlat, rlon, rlat, inttyp, gauout, len, lmask, rslmsk, slmask, outlat, outlon, me)
This subroutine conducts interpolation from lat/lon to Gaussian grid to other lat/lon grid.
Definition sfcsub.F:3125
subroutine usesgt(sig1t, slianl, tg3anl, len, lsoil, tsfanl, stcanl, tsfimx)
Definition sfcsub.F:6003
subroutine dayoyr(iyr, imo, idy, ldy)
This subroutine figures out the day of the year given imo and idy.
Definition sfcsub.F:2752
subroutine snodpth(scvanl, slianl, tsfanl, snoclm, glacir, snwmax, snwmin, landice, len, snoanl, me)
This subroutine uses surface temperature to get snow depth estimate.
Definition sfcsub.F:4711
subroutine analy(lugb, iy, im, id, ih, fh, len, lsoil, slmskl, slmskw, fntsfa, fnweta, fnsnoa, fnzora, fnalba, fnaisa, fntg3a, fnscva, fnsmca, fnstca, fnacna, fnvega, fnveta, fnsota, fnsoca, fnvmna, fnvmxa, fnslpa, fnabsa, tsfanl, wetanl, snoanl, zoranl, albanl, aisanl, tg3anl, cvanl, cvbanl, cvtanl, smcanl, stcanl, slianl, scvanl, acnanl, veganl, vetanl, sotanl, socanl, alfanl, tsfan0, vmnanl, vmxanl, slpanl, absanl, kpdtsf, kpdwet, kpdsno, kpdsnd, kpdzor, kpdalb, kpdais, kpdtg3, kpdscv, kpdacn, kpdsmc, kpdstc, kpdveg, kprvet, kpdsot, kpdsoc, kpdalf, kpdvmn, kpdvmx, kpdslp, kpdabs, irttsf, irtwet, irtsno, irtzor, irtalb, irtais, irttg3, irtscv, irtacn, irtsmc, irtstc, irtveg, irtvet, irtsot, irtsoc, irtalf, irtvmn, irtvmx, irtslp, irtabs, imsk, jmsk, slmskh, outlat, outlon, gaus, blno, blto, me, lanom)
Definition sfcsub.F:3805
integer kpdtg3
Definition sfcsub.F:17
integer kpdplr
Definition sfcsub.F:17
subroutine filfcs(tsffcs, wetfcs, snofcs, zorfcs, albfcs, tg3fcs, cvfcs, cvbfcs, cvtfcs, cnpfcs, smcfcs, stcfcs, slifcs, aisfcs, vegfcs, vetfcs, sotfcs, socfcs, alffcs, sihfcs, sicfcs, vmnfcs, vmxfcs, slpfcs, absfcs, tsfanl, wetanl, snoanl, zoranl, albanl, tg3anl, cvanl, cvbanl, cvtanl, cnpanl, smcanl, stcanl, slianl, aisanl, veganl, vetanl, sotanl, socanl, alfanl, sihanl, sicanl, vmnanl, vmxanl, slpanl, absanl, len, lsoil)
Definition sfcsub.F:4490
subroutine qcsice(ais, glacir, amxice, aicice, aicsea, sllnd, slmask, rla, rlo, len, me)
Definition sfcsub.F:5374
subroutine fixrdc_tile(filename_raw, tile_num_ch, i_index, j_index, kpds, var, mon, npts, me)
Definition sfcsub.F:8250
subroutine qcbyfc(tsffcs, snofcs, qctsfs, qcsnos, qctsfi, len, lsoil, snoanl, aisanl, slianl, tsfanl, albanl, zoranl, smcanl, smcclm, tsfsmx, albomx, zoromx, me)
Definition sfcsub.F:6160
subroutine ga2la(gauin, imxin, jmxin, regout, imxout, jmxout, wlon, rnlat, rlnout, rltout, gaus, blno, blto)
This subroutine interpolates from lat/lon grid to other lat/lon grid.
Definition sfcsub.F:6742
subroutine gaulat(gaul, k)
Definition sfcsub.F:7009
integer, dimension(4), parameter kpdalb_1
Definition sfcsub.F:33
subroutine scale(fld, len, scl)
Definition sfcsub.F:5493
integer kpdwet
Definition sfcsub.F:17