← Back to Documentation Home
CCPP SciDoc v8.0.0  v8.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
module_sf_ruclsm.F90
1
3
9MODULE module_sf_ruclsm
10
11 use machine , only : kind_phys, kind_dbl_prec
12 use namelist_soilveg_ruc
13 use physcons, only : rhowater, con_t0c, con_hfus, con_hvap, &
14 con_pi, con_rv, con_g, con_csol, con_tice
15
16 implicit none
17
18 private
19 !private qsn
20
21 public :: lsmruc, ruclsminit, rslf
22
25 real (kind_phys), parameter :: tfrz = con_t0c
26 real (kind_phys), parameter :: xls = con_hvap + con_hfus
27 real (kind_phys), parameter :: piconst = con_pi
28 real (kind_phys), parameter :: r_v = con_rv
29 real (kind_phys), parameter :: grav = con_g
30 real (kind_phys), parameter :: sheatice = con_csol
31
32 real (kind_phys), parameter :: rhoice = 917._kind_phys ! ice density
33 real (kind_phys), parameter :: sheatsn = 2090._kind_phys ! snow heat capacity
34 real (kind_phys), parameter :: P1000mb = 100000._kind_phys
35
36 real (kind_phys), parameter :: zero = 0._kind_dbl_prec
37 real (kind_phys), parameter :: one = 1._kind_dbl_prec
38
39 !-- options for snow conductivity: 1 - constant, 2 - Sturm et al.,1997
40 !integer, parameter :: isncond_opt = 1
41 !-- Snow fraction options
42 !-- option 1: original formulation using threshold snow depth to compute snow fraction
43 !integer, parameter :: isncovr_opt = 1
44 !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L., 2007,JGR,DOI:10.1029/2007JD008674.
45 !integer, parameter :: isncovr_opt = 2
46 !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z with
47 ! vegetation-dependent parameters from Noah MP (personal communication with
48 ! Mike Barlage)
49 !integer, parameter :: isncovr_opt = 3
50
51 !-- Mosaic_lu and mosaic_soil are defined in set_soilveg_ruc.F90 and
52 ! passes to RUC LSM via namelist_soilveg_ruc.F90.
53
54!! @}
55
58 INTEGER :: LUCATS
59 integer, PARAMETER :: NLUS=50
60 CHARACTER*8 LUTYPE
61!! @}
62
65 INTEGER :: SLCATS
66 INTEGER, PARAMETER :: NSLTYPE=30
67 CHARACTER*8 SLTYPE
68!! @}
69
72 INTEGER :: SLPCATS
73 INTEGER, PARAMETER :: NSLOPE=30
74 real (kind_phys) :: SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, &
75 REFKDT_DATA,FRZK_DATA,ZBOT_DATA, SMLOW_DATA,SMHIGH_DATA, &
76 CZIL_DATA
77!! @}
78
79
80CONTAINS
81
82!-----------------------------------------------------------------
88 SUBROUTINE lsmruc(xlat,xlon, &
89 DT,init,lsm_cold_start,KTAU,iter,NSL, &
90 graupelncv,snowncv,rainncv,raincv, &
91 ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, &
92 rhosnf,precipfr,exticeden, hgt,stdev, &
93 Z3D,P8W,T3D,QV3D,QC3D,RHO3D,EMISBCK, &
94 GLW,GSWdn,GSW,EMISS,CHKLOWQ, CHS, &
95 FLQC,FLHC,rhonewsn_ex,mosaic_lu, &
96 mosaic_soil,isncond_opt,isncovr_opt, &
97 MAVAIL,CANWAT,VEGFRA, &
98 ALB,ZNT,Z0,SNOALB,ALBBCK,LAI, &
99 landusef, nlcat, soilctop, nscat, &
100 smcwlt, smcref, &
101 QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV, &
102 TBOT,IVGTYP,ISLTYP,XLAND, &
103 ISWATER,ISICE,XICE,XICE_THRESHOLD, &
104 CP,RV,RD,G0,PI,LV,STBOLT, &
105 SOILMOIS,SH2O,SMAVAIL,SMMAX, &
106 TSO,SOILT,EDIR,EC,ETT,SUBLIM,SNOH, &
107 HFX,QFX,LH,INFILTR, &
108 RUNOFF1,RUNOFF2,ACRUNOFF,SFCEXC, &
109 SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, &
110 SMFR3D,KEEPFR3DFLAG, &
111 add_fire_heat_flux,fire_heat_flux, &
112 myj,shdmin,shdmax,rdlai2d, &
113 ims,ime, jms,jme, kms,kme, &
114 its,ite, jts,jte, kts,kte, &
115 errmsg, errflg)
116!-----------------------------------------------------------------
117 IMPLICIT NONE
118!-----------------------------------------------------------------
119!
120! The RUC LSM model is described in:
121! Smirnova, T.G., J.M. Brown, and S.G. Benjamin, 1997:
122! Performance of different soil model configurations in simulating
123! ground surface temperature and surface fluxes.
124! Mon. Wea. Rev. 125, 1870-1884.
125! Smirnova, T.G., J.M. Brown, and D. Kim, 2000: Parameterization of
126! cold-season processes in the MAPS land-surface scheme.
127! J. Geophys. Res. 105, 4077-4086.
128!-----------------------------------------------------------------
129!-- DT time step (second)
130! init - flag for initialization
131!lsm_cold_start - flag for cold start run
132! ktau - number of time step
133! NSL - number of soil layers
134! NZS - number of levels in soil
135! ZS - depth of soil levels (m)
136!-- RAINBL - accumulated rain in [mm] between the PBL calls
137!-- RAINNCV one time step grid scale precipitation (mm/step)
138!-- RAINCV one time step convective precipitation (mm/step)
139! SNOW - snow water equivalent [mm]
140! FRAZFRAC - fraction of frozen precipitation
141!-- PRECIPFR (mm) - time step frozen precipitation
142!-- SNOWC flag indicating snow coverage (1 for snow cover)
143!-- Z3D heights (m)
144!-- P8W 3D pressure (Pa)
145!-- T3D temperature (K)
146!-- QV3D 3D water vapor mixing ratio (Kg/Kg)
147! QC3D - 3D cloud water mixing ratio (Kg/Kg)
148! RHO3D - 3D air density (kg/m^3)
149!-- GLW downward long wave flux at ground surface (W/m^2)
150!-- GSW absorbed short wave flux at ground surface (W/m^2)
151!-- EMISS surface emissivity (between 0 and 1)
152! FLQC - surface exchange coefficient for moisture (kg/m^2/s)
153! FLHC - surface exchange coefficient for heat [W/m^2/s/degreeK]
154! SFCEXC - surface exchange coefficient for heat [m/s]
155! CANWAT - CANOPY MOISTURE CONTENT (mm)
156! VEGFRA - vegetation fraction (between 0 and 100)
157! ALB - surface albedo (between 0 and 1)
158! SNOALB - maximum snow albedo (between 0 and 1)
159! ALBBCK - snow-free albedo (between 0 and 1)
160! ZNT - roughness length [m]
161!-- TBOT soil temperature at lower boundary (K)
162! IVGTYP - USGS vegetation type (24 classes)
163! ISLTYP - STASGO soil type (16 classes)
164!-- XLAND land mask (1 for land, 2 for water)
165!-- CP heat capacity at constant pressure for dry air (J/kg/K)
166!-- G0 acceleration due to gravity (m/s^2)
167!-- LV latent heat of evaporation (J/kg)
168!-- STBOLT Stefan-Boltzmann constant (W/m^2/K^4)
169! SOILMOIS - soil moisture content (volumetric fraction)
170! TSO - soil temp (K)
171!-- SOILT surface temperature (K)
172!-- HFX upward heat flux at the surface (W/m^2)
173!-- QFX upward moisture flux at the surface (kg/m^2/s)
174!-- LH upward latent heat flux (W/m^2)
175! SFCRUNOFF - ground surface runoff [mm]
176! UDRUNOFF - underground runoff [mm]
177! ACRUNOFF - run-total surface runoff [mm]
178! SFCEVP - total time-step evaporation in [kg/m^2]
179! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface)
180! SNOWFALLAC - run-total snowfall accumulation [mm]
181! ACSNOW - run-toral SWE of snowfall [mm]
182!-- CHKLOWQ - is either 0 or 1 (so far set equal to 1).
183!-- used only in MYJPBL.
184!-- tice - sea ice temperture (C)
185!-- rhosice - sea ice density (kg m^-3)
186!-- capice - sea ice volumetric heat capacity (J/m^3/K)
187!-- thdifice - sea ice thermal diffusivity (m^2/s)
188!--
189!-- ims start index for i in memory
190!-- ime end index for i in memory
191!-- jms start index for j in memory
192!-- jme end index for j in memory
193!-- kms start index for k in memory
194!-- kme end index for k in memory
195!-------------------------------------------------------------------------
196! INTEGER, PARAMETER :: nzss=5
197! INTEGER, PARAMETER :: nddzs=2*(nzss-2)
198
199 real (kind_phys), INTENT(IN ) :: xlat,xlon
200 real (kind_phys), INTENT(IN ) :: dt
201 LOGICAL, INTENT(IN ) :: myj,frpcpn,init,lsm_cold_start,exticeden
202 INTEGER, INTENT(IN ) :: nlcat, nscat
203 INTEGER, INTENT(IN ) :: mosaic_lu,mosaic_soil
204 INTEGER, INTENT(IN ) :: isncond_opt,isncovr_opt
205 INTEGER, INTENT(IN ) :: ktau, iter, nsl, isice, iswater, &
206 ims,ime, jms,jme, kms,kme, &
207 its,ite, jts,jte, kts,kte
208
209! LOGICAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: flag_iter, flag
210
211 real (kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ) , &
212 INTENT(IN ) :: qv3d, &
213 qc3d, &
214 p8w, &
215 rho3d, &
216 t3d, &
217 z3d
218
219 real (kind_phys), DIMENSION( ims:ime , jms:jme ), &
220 INTENT(IN ) :: rainbl, &
221 glw, &
222 gswdn, &
223 gsw, &
224 albbck, &
225 flhc, &
226 flqc, &
227 chs , &
228 xice, &
229 xland, &
230 vegfra, &
231 tbot
232
233 real (kind_phys), DIMENSION( ims:ime , jms:jme ), &
234 INTENT(IN ) :: graupelncv, &
235 snowncv, &
236 raincv, &
237 rainncv
238 real (kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: rhonewsn_ex !externally-calculated srf frz precip density
239
240 real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: shdmax
241 real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: shdmin
242 real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: hgt
243 real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: stdev
244 LOGICAL, intent(in) :: add_fire_heat_flux
245 real (kind_phys), DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: fire_heat_flux
246 LOGICAL, intent(in) :: rdlai2d
247
248 real (kind_phys), DIMENSION( 1:nsl), INTENT(IN ) :: zs
249
250 real (kind_phys), DIMENSION( ims:ime , jms:jme ), &
251 INTENT(INOUT) :: &
252 snow, &
253 snowh, &
254 snowc, &
255 canwat, &
256 snoalb, &
257 alb, &
258 lai, &
259 smcwlt, &
260 smcref, &
261 emiss, &
262 emisbck, &
263 mavail, &
264 sfcexc, &
265 z0 , &
266 znt
267
268 real (kind_phys), DIMENSION( ims:ime , jms:jme ), &
269 INTENT(IN ) :: &
270 frzfrac
271
272 INTEGER, DIMENSION( ims:ime , jms:jme ), &
273 INTENT(IN ) :: ivgtyp, &
274 isltyp
275 real (kind_phys), DIMENSION( ims:ime , 1:nlcat, jms:jme ), INTENT(IN):: landusef
276 real (kind_phys), DIMENSION( ims:ime , 1:nscat, jms:jme ), INTENT(IN):: soilctop
277
278 real (kind_phys), INTENT(IN ) :: cp,g0,lv,stbolt,rv,rd,pi, &
279 xice_threshold
280
281 real (kind_phys), DIMENSION( ims:ime , 1:nsl, jms:jme ) , &
282 INTENT(INOUT) :: soilmois,sh2o,tso
283
284 real (kind_phys), DIMENSION( ims:ime, jms:jme ) , &
285 INTENT(INOUT) :: soilt, &
286 hfx, &
287 qfx, &
288 lh, &
289 edir, &
290 ec, &
291 ett, &
292 sublim, &
293 snoh, &
294 sfcevp, &
295 runoff1, &
296 runoff2, &
297 acrunoff, &
298 grdflx, &
299 acsnow, &
300 snom, &
301 qvg, &
302 qcg, &
303 dew, &
304 qsfc, &
305 qsg, &
306 chklowq, &
307 soilt1, &
308 tsnav
309
310 real (kind_phys), DIMENSION( ims:ime, jms:jme ) , &
311 INTENT(INOUT) :: smavail, &
312 smmax
313
314 real (kind_phys), DIMENSION( its:ite, jts:jte ) :: &
315 pc, &
316 sfcrunoff, &
317 udrunoff, &
318 emissl, &
319 msnf, &
320 facsnf, &
321 zntl, &
322 lmavail, &
323 smelt, &
324 snflx, &
325 sflx, &
326 smf, &
327 evapl, &
328 prcpl, &
329 seaice, &
330 infiltr
331! Energy and water budget variables:
332 real (kind_phys), DIMENSION( its:ite, jts:jte ) :: &
333 budget, &
334 acbudget, &
335 waterbudget, &
336 acwaterbudget, &
337 smtotold, &
338 snowold, &
339 canwatold
340
341
342 real (kind_phys), DIMENSION( ims:ime, 1:nsl, jms:jme) &
343 :: keepfr3dflag, &
344 smfr3d
345
346 real (kind_phys),DIMENSION( ims:ime, jms:jme ),INTENT(OUT) :: &
347 rhosnf, & ! RHO of snowfall
348 precipfr, & ! time-step frozen precip
349 snowfallac
350!--- soil/snow properties
351 real (kind_phys) &
352 :: rhocs, &
353 rhonewsn, &
354 rhosn, &
355 rhosnfall, &
356 bclh, &
357 dqm, &
358 ksat, &
359 psis, &
360 qmin, &
361 qwrtz, &
362 ref, &
363 wilt, &
364 canwatr, &
365 snowfrac, &
366 snhei, &
367 snwe
368
369 real (kind_phys) :: cn, &
370 sat,cw, &
371 c1sn, &
372 c2sn, &
373 kqwrtz, &
374 kice, &
375 kwt
376
377
378 real (kind_phys), DIMENSION(1:NSL) :: zsmain, &
379 zshalf, &
380 dtdzs2
381
382 real (kind_phys), DIMENSION(1:2*(nsl-2)) :: dtdzs
383
384 real (kind_phys), DIMENSION(1:5001) :: tbq
385
386
387 real (kind_phys), DIMENSION( 1:nsl ) :: soilm1d, &
388 tso1d, &
389 soilice, &
390 soiliqw, &
391 smfrkeep
392
393 real (kind_phys), DIMENSION( 1:nsl ) :: keepfr
394
395 real (kind_phys), DIMENSION( 1:nlcat ) :: lufrac
396 real (kind_phys), DIMENSION( 1:nscat ) :: soilfrac
397
398 real (kind_phys) :: rsm, &
399 snweprint, &
400 snheiprint
401
402 real (kind_phys) :: prcpms, &
403 newsnms, &
404 prcpncliq, &
405 prcpncfr, &
406 prcpculiq, &
407 prcpcufr, &
408 patm, &
409 patmb, &
410 tabs, &
411 qvatm, &
412 qcatm, &
413 q2sat, &
414 conflx, &
415 rho, &
416 qkms, &
417 tkms, &
418 snowrat, &
419 grauprat, &
420 icerat, &
421 curat, &
422 infiltrp
423 real (kind_phys) :: cq,r61,r273,arp,brp,x,evs,eis
424 real (kind_phys) :: cropfr, cropsm, newsm, factor
425
426 real (kind_phys) :: meltfactor, ac,as, wb,rovcp
427 INTEGER :: nroot
428 INTEGER :: iland,isoil,iforest
429
430 INTEGER :: i,j,k,nzs,nzs1,nddzs
431 INTEGER :: k1,k2
432 logical :: debug_print
433
434 !-- diagnostic point
435 real (kind_phys) :: testptlat, testptlon
436
437 character(len=*),intent(out) :: errmsg
438 integer, intent(out) :: errflg
439
440!-----------------------------------------------------------------
441!
442 ! Initialize error-handling
443 errflg = 0
444 errmsg = ''
445
446 debug_print = .false.
447!
448 rovcp = rd/cp
449
450 nzs=nsl
451 nddzs=2*(nzs-2)
452
453 !--
454 testptlat = 35.55 !48.7074_kind_phys !39.958 !42.05 !39.0 !74.12 !29.5
455 testptlon = 278.66 !289.03_kind_phys !271.622 !286.75 !280.6 !164.0 !283.0
456 !--
457
458
460 cq=173.15_kind_dbl_prec-.05_kind_dbl_prec
461 r273=1._kind_dbl_prec/tfrz
462 r61=6.1153_kind_dbl_prec*0.62198_kind_dbl_prec
463 arp=77455._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec
464 brp=64._kind_dbl_prec*41.9_kind_dbl_prec/461.525_kind_dbl_prec
465
466 DO k=1,5001
467 cq=cq+.05_kind_dbl_prec
468 evs=exp(17.67_kind_dbl_prec*(cq-tfrz)/(cq-29.65_kind_dbl_prec))
469 eis=exp(22.514_kind_dbl_prec-6.15e3_kind_dbl_prec/cq)
470 if(cq.ge.tfrz) then
471 ! tbq is in mb
472 tbq(k) = r61*evs
473 else
474 tbq(k) = r61*eis
475 endif
476 END DO
477
479!--- This is temporary until SI is added to mass coordinate ---!!!!!
480
481 if(init .and. iter == 1) then
482
483 if( lsm_cold_start ) then
484 !-- beginning of cold-start
485 DO j=jts,jte
486 DO i=its,ite
487!
489 IF((soilt1(i,j) .LT. 170._kind_phys) .or. (soilt1(i,j) .GT.400._kind_phys)) THEN
490 IF(snowc(i,j).gt.zero) THEN
491 soilt1(i,j)=min(tfrz,0.5_kind_phys*(soilt(i,j)+tso(i,1,j)) )
492 IF (debug_print ) THEN
493 print *, &
494 'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,xlat,xlon
495 ENDIF
496 ELSE
497 soilt1(i,j) = tso(i,1,j)
498 ENDIF
499 ENDIF
500 tsnav(i,j) =min(zero,0.5_kind_phys*(soilt(i,j)+tso(i,1,j))-tfrz)
501 !- 10feb22 - limit snow albedo at high elevations
502 !- based on Roesch et al., Climate Dynamics (2001),17:933-946
503 if(hgt(i,j) > 2500._kind_phys) then
504 snoalb(i,j) = min(0.65_kind_phys,snoalb(i,j))
505 endif
506
507 patmb=p8w(i,kms,j)*1.e-2_kind_phys
508 qsg(i,j) = qsn(soilt(i,j),tbq)/patmb
509
510 if((qcg(i,j) < zero) .or. (qcg(i,j) > 0.1_kind_phys)) then
511 qcg(i,j) = qc3d(i,1,j)
512 if (debug_print ) then
513 print *, 'QCG is initialized in RUCLSM ', qcg(i,j),qc3d(i,1,j),i,xlat,xlon
514 endif
515 endif
516
517 if((qvg(i,j) .LE. zero) .or. (qvg(i,j) .GT.0.1_kind_phys)) then
518 qvg(i,j) = qv3d(i,1,j)
519 if (debug_print ) then
520 print *, 'QVG is initialized in RUCLSM ', qvg(i,j),mavail(i,j),qsg(i,j),i,xlat,xlon
521 endif
522 endif
523 qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
524
525 smelt(i,j) = zero
526 snom(i,j) = zero
527 acsnow(i,j) = zero
528 snowfallac(i,j) = zero
529 precipfr(i,j) = zero
530 rhosnf(i,j) = -1.e3_kind_phys ! non-zero flag
531 snflx(i,j) = zero
532 dew(i,j) = zero
533 pc(i,j) = zero
534 zntl(i,j) = zero
535 runoff1(i,j) = zero
536 runoff2(i,j) = zero
537 sfcrunoff(i,j) = zero
538 udrunoff(i,j) = zero
539 acrunoff(i,j) = zero
540 emissl(i,j) = zero
541 msnf(i,j) = zero
542 facsnf(i,j) = zero
543 budget(i,j) = zero
544 acbudget(i,j) = zero
545 waterbudget(i,j) = zero
546 acwaterbudget(i,j) = zero
547 smtotold(i,j)=zero
548 canwatold(i,j)=zero
549
553 chklowq(i,j) = one
554 infiltr(i,j) = zero
555 snoh(i,j) = zero
556 edir(i,j) = zero
557 ec(i,j) = zero
558 ett(i,j) = zero
559 sublim(i,j) = zero
560 sflx(i,j) = zero
561 smf(i,j) = zero
562 evapl(i,j) = zero
563 prcpl(i,j) = zero
564 ENDDO
565 ENDDO
566
567 infiltrp = zero
568 do k=1,nsl
569 soilice(k)=zero
570 soiliqw(k)=zero
571 enddo
572 endif ! cold start
573 endif ! init==.true.
574
575!-----------------------------------------------------------------
576
577 prcpms = zero
578 newsnms = zero
579 prcpncliq = zero
580 prcpculiq = zero
581 prcpncfr = zero
582 prcpcufr = zero
583
584 DO j=jts,jte
585
586 DO i=its,ite
587
588 IF (debug_print ) THEN
589 if (abs(xlat-testptlat).lt.0.2 .and. &
590 abs(xlon-testptlon).lt.0.2)then
591 print 100,'(RUC start) i=',i,' lat,lon=',xlat,xlon, &
592 'mavail ', mavail(i,j),' soilt',soilt(i,j),'qvg ',qvg(i,j),&
593 'p8w',p8w(i,1,j),'sflay qfx',qfx(i,j),'sflay hfx',hfx(i,j),&
594 'gsw ',gsw(i,j),'glw ',glw(i,j),'soilt ',soilt(i,j), &
595 'chs ',chs(i,j),'flqc ',flhc(i,j),'alb ',alb(i,j), &
596 'rainbl ',rainbl(i,j),'dt ',dt
597 print *,'nzs',nzs, 'ivgtyp ',ivgtyp(i,j),'isltyp ',isltyp(i,j)
598 endif
599 ENDIF
600
601 iland = ivgtyp(i,j)
602 isoil = isltyp(i,j)
603 tabs = t3d(i,kms,j)
604 qvatm = qv3d(i,kms,j)
605 qcatm = qc3d(i,kms,j)
606 patm = p8w(i,kms,j)*1.e-5_kind_phys
610 conflx = z3d(i,kms,j)*0.5_kind_phys
611 rho = rho3d(i,kms,j)
613 snowrat = zero
614 grauprat = zero
615 icerat = zero
616 curat = zero
617 IF(frpcpn) THEN
618 prcpncliq = rainncv(i,j)*(1.-frzfrac(i,j))
619 prcpncfr = rainncv(i,j)*frzfrac(i,j)
621!tgs - 31 mar17 - add temperature check in case Thompson MP produces
622! frozen precip at T > 273.
623 if(frzfrac(i,j) > zero .and. tabs < tfrz) then
624 prcpculiq = max(zero,raincv(i,j)*(one-frzfrac(i,j)))
625 prcpcufr = max(zero,raincv(i,j)*frzfrac(i,j))
626 else
627 if(tabs < tfrz) then
628 prcpcufr = max(zero,raincv(i,j))
629 prcpculiq = zero
630 else
631 prcpcufr = zero
632 prcpculiq = max(zero,raincv(i,j))
633 endif ! tabs < 273.
634 endif ! frzfrac > 0.
635!--- 1*e-3 is to convert from mm/s to m/s
636 prcpms = (prcpncliq + prcpculiq)/dt*1.e-3_kind_phys
637 newsnms = (prcpncfr + prcpcufr)/dt*1.e-3_kind_phys
638
639 if((prcpncfr + prcpcufr) > zero) then
641 snowrat=min(one,max(zero,snowncv(i,j)/(prcpncfr + prcpcufr)))
642 grauprat=min(one,max(zero,graupelncv(i,j)/(prcpncfr + prcpcufr)))
643 icerat=min(one,max(zero,(prcpncfr-snowncv(i,j)-graupelncv(i,j)) &
644 /(prcpncfr + prcpcufr)))
645 curat=min(one,max(zero,(prcpcufr/(prcpncfr + prcpcufr))))
646 endif
647
648 ELSE ! .not. FRPCPN
649 if (tabs.le.tfrz) then
650 prcpms = zero
651 newsnms = rainbl(i,j)/dt*1.e-3_kind_phys
654 snowrat = one
655 else
656 prcpms = rainbl(i,j)/dt*1.e-3_kind_phys
657 newsnms = zero
658 endif
659 ENDIF
660
661! -- save time-step water equivalent of frozen precipitation in PRECIPFR array to be used in
662! module_diagnostics
663 precipfr(i,j) = newsnms * dt *1.e3_kind_phys
664
665 if (myj) then
666 qkms=chs(i,j)
667 tkms=chs(i,j)
668 else
670 qkms=flqc(i,j)/rho/mavail(i,j)
671! TKMS=FLHC(I,J)/RHO/CP
672 tkms=flhc(i,j)/rho/(cp*(one+0.84_kind_phys*qvatm)) ! mynnsfc uses CPM
673 endif
675 snwe=snow(i,j)*1.e-3_kind_phys
676 snhei=snowh(i,j)
677 canwatr=canwat(i,j)*1.e-3_kind_phys
678
679 snowfrac=snowc(i,j)
680 rhosnfall=rhosnf(i,j)
681
682 snowold(i,j)=snwe
683!-----
684 zsmain(1)=zero
685 zshalf(1)=zero
686 do k=2,nzs
687 zsmain(k)= zs(k)
688 zshalf(k)=0.5_kind_phys*(zsmain(k-1) + zsmain(k))
689 enddo
690
691 do k=1,nlcat
692 lufrac(k) = landusef(i,k,j)
693 enddo
694 do k=1,nscat
695 soilfrac(k) = soilctop(i,k,j)
696 enddo
697
698!------------------------------------------------------------
699!----- DDZS and DSDZ1 are for implicit solution of soil eqns.
700!-------------------------------------------------------------
701 nzs1=nzs-1
702!-----
703 IF (debug_print ) THEN
704 print *,' DT,NZS1, ZSMAIN, ZSHALF --->', dt,nzs1,zsmain,zshalf
705 ENDIF
706
707 DO k=2,nzs1
708 k1=2*k-3
709 k2=k1+1
710 x=dt/2./(zshalf(k+1)-zshalf(k))
711 dtdzs(k1)=x/(zsmain(k)-zsmain(k-1))
712 dtdzs2(k-1)=x
713 dtdzs(k2)=x/(zsmain(k+1)-zsmain(k))
714 END DO
715
716 cw =4.183e6_kind_dbl_prec
717
718
719!--- Constants used in Johansen soil thermal
720!--- conductivity method
721
722 kqwrtz=7.7_kind_dbl_prec
723 kice=2.2_kind_dbl_prec
724 kwt=0.57_kind_dbl_prec
725
726!***********************************************************************
727!--- Constants for snow density calculations C1SN and C2SN
728
729 c1sn=0.026_kind_dbl_prec
730 c2sn=21._kind_dbl_prec
731
732!***********************************************************************
733
734 nroot= 4
735! ! rooting depth
736
737 rhonewsn = 200._kind_phys
738 if(snow(i,j).gt.zero .and. snowh(i,j).gt.0.02_kind_phys) then
739 rhosn = snow(i,j)/snowh(i,j)
740 else
741 rhosn = 300._kind_phys
742 endif
743
744 IF (debug_print ) THEN
745 if(init) then
746 if (abs(xlat-testptlat).lt.0.2 .and. &
747 abs(xlon-testptlon).lt.0.2)then
748 print*,' lat,lon=',xlat,xlon
749 print *,'before SOILVEGIN - z0,znt',i,z0(i,j),znt(i,j)
750 print *,'ILAND, ISOIL =',i,iland,isoil
751 endif
752 endif
753 ENDIF
754
756 !-- land or ice
757 CALL soilvegin ( debug_print, mosaic_lu, mosaic_soil, &
758 soilfrac,nscat,shdmin(i,j),shdmax(i,j), &
759 nlcat,iland,isoil,iswater,myj,iforest,lufrac,vegfra(i,j), &
760 emissl(i,j),pc(i,j),msnf(i,j),facsnf(i,j), &
761 znt(i,j),lai(i,j),rdlai2d, &
762 qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt,i,j,errmsg, errflg)
763
764 !-- update background emissivity for land points, can have vegetation mosaic effect
765 emisbck(i,j) = emissl(i,j)
766 smcwlt(i,j) = wilt
767 smcref(i,j) = ref
768
769 IF (debug_print ) THEN
770 if(init)then
771 if (abs(xlat-testptlat).lt.0.2 .and. &
772 abs(xlon-testptlon).lt.0.2)then
773 print*,' lat,lon=',xlat,xlon
774 print *,'after SOILVEGIN - z0,znt,lai',i,z0(i,j),znt(i,j),lai(i,j)
775 print *,'NLCAT,iland,EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J)', &
776 nlcat,iland,emissl(i,j),pc(i,j),znt(i,j),lai(i,j),i,j
777 print *,'NSCAT,QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT',&
778 nscat,qwrtz,rhocs,bclh,dqm,ksat,psis,qmin,ref,wilt,i,j
779 endif
780 endif
781 ENDIF
782
783 cn=cfactr_data ! exponent
784 sat = 5.e-4_kind_phys ! units [m]
785
786!-- definition of number of soil levels in the rooting zone
787 IF(iforest.gt.2) THEN
788!---- all vegetation types except evergreen and mixed forests
789!18apr08 - define meltfactor for Egglston melting limit:
790! for open areas factor is 2, and for forests - factor is 0.85
791! This will make limit on snow melting smaller and let snow stay
792! longer in the forests.
793 meltfactor = 2.0_kind_phys
794
795 do k=2,nzs
796 if(zsmain(k).ge.0.4_kind_phys) then
797 nroot=k
798 exit
799 endif
800 enddo
801 ELSE
802!---- evergreen and mixed forests
803!18apr08 - define meltfactor
804! meltfactor = 1.5
805! 28 March 11 - Previously used value of metfactor= 1.5 needs to be further reduced
806! to compensate for low snow albedos in the forested areas.
807! Melting rate in forests will reduce.
808 meltfactor = 0.85_kind_phys
809
810 do k=2,nzs
811 if(zsmain(k).ge.1.1_kind_phys) then
812 nroot=k
813 exit
814 endif
815 enddo
816 ENDIF
817
818!-----
819 IF (debug_print ) THEN
820 if (abs(xlat-testptlat).lt.0.2 .and. &
821 abs(xlon-testptlon).lt.0.2)then
822 print*,' lat,lon=',xlat,xlon
823 print *,' ZNT, LAI, VEGFRA, SAT, EMIS, PC --->', &
824 znt(i,j),lai(i,j),vegfra(i,j),sat,emissl(i,j),pc(i,j)
825 print *,' ZS, ZSMAIN, ZSHALF, CONFLX, CN, SAT, --->', zs,zsmain,zshalf,conflx,cn,sat
826 print *,'NROOT, meltfactor, iforest, ivgtyp, i,j ', nroot,meltfactor,iforest,ivgtyp(i,j),i,j
827 endif
828 ENDIF
829
830 IF((xland(i,j)-1.5).GE.0._kind_phys)THEN
831!-- Water
832 smavail(i,j)= one
833 smmax(i,j)= one
834 snow(i,j) = zero
835 snowh(i,j)= zero
836 snowc(i,j)= zero
837 lmavail(i,j)= one
838! accumulated water equivalent of frozen precipitation over water [mm]
839 acsnow(i,j)=acsnow(i,j)+precipfr(i,j)
840
841 iland=iswater
842 isoil=14
843
844 patmb=p8w(i,1,j)*1.e-2_kind_phys
845 qvg(i,j) = qsn(soilt(i,j),tbq)/patmb
846 qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
847 chklowq(i,j)= one
848 q2sat=qsn(tabs,tbq)/patmb
849
850 DO k=1,nzs
851 soilmois(i,k,j)=one
852 sh2o(i,k,j)=one
853 tso(i,k,j)= soilt(i,j)
854 ENDDO
855
856 IF (debug_print ) THEN
857 if (abs(xlat-testptlat).lt.0.2 .and. &
858 abs(xlon-testptlon).lt.0.2)then
859 print*,' water point'
860 print*,' lat,lon=',xlat,xlon,'SOILT=', soilt(i,j)
861 endif
862 ENDIF
863
864 ELSE
865
866! LAND POINT OR SEA ICE
867 if(xice(i,j).ge.xice_threshold) then
868 seaice(i,j)=one
869 else
870 seaice(i,j)=zero
871 endif
872
873 IF(seaice(i,j).GT.0.5_kind_phys)THEN
874!-- Sea-ice case
875 IF (debug_print ) THEN
876 if (abs(xlat-testptlat).lt.0.2 .and. &
877 abs(xlon-testptlon).lt.0.2)then
878 print*,' sea-ice at water point'
879 print*,' lat,lon=',xlat,xlon
880 endif
881 ENDIF
882 iland = isice
883 if(nscat == 9) then
884 isoil = 9 ! ZOBLER
885 else
886 isoil = 16 ! STATSGO
887 endif
888 znt(i,j) = 0.011_kind_phys
889 ! in FV3 albedo and emiss are defined for ice
890 emissl(i,j) = emisbck(i,j) ! no snow impact, old 0.98 used in WRF
891 dqm = one
892 ref = one
893 qmin = zero
894 wilt = zero
895
896 patmb=p8w(i,1,j)*1.e-2_kind_phys
897 qvg(i,j) = qsn(soilt(i,j),tbq)/patmb
898 qsg(i,j) = qvg(i,j)
899 qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
900
901 DO k=1,nzs
902 soilmois(i,k,j) = one
903 smfr3d(i,k,j) = one
904 sh2o(i,k,j) = zero
905 keepfr3dflag(i,k,j) = zero
906 tso(i,k,j) = min(con_tice,tso(i,k,j))
907 ENDDO
908 ENDIF
909
910! Attention!!!! RUC LSM uses soil moisture content minus residual (minimum
911! or dry soil moisture content for a given soil type) as a state variable.
912
913 DO k=1,nzs
914 ! soilm1d - soil moisture content minus residual [m**3/m**3]
915 soilm1d(k) = min(max(zero,soilmois(i,k,j)-qmin),dqm)
916 tso1d(k) = tso(i,k,j)
917 soiliqw(k) = min(max(zero,sh2o(i,k,j)-qmin),soilm1d(k))
918 soilice(k) =(soilm1d(k) - soiliqw(k))/0.9_kind_phys
919 ENDDO
920
921 do k=1,nzs
922 smfrkeep(k) = smfr3d(i,k,j)
923 keepfr(k) = keepfr3dflag(i,k,j)
924 enddo
925
926 lmavail(i,j)=max(0.00001_kind_phys,min(one,soilm1d(1)/(ref-qmin)))
927
928 IF (debug_print ) THEN
929 if (abs(xlat-testptlat).lt.0.2 .and. &
930 abs(xlon-testptlon).lt.0.2)then
931 print*,' lat,lon=',xlat,xlon
932 print *,'LAND, i,j,tso1d,soilm1d,PATM,TABS,QVATM,QCATM,RHO', &
933 i,j,tso1d,soilm1d,patm,tabs,qvatm,qcatm,rho
934 print *,'CONFLX =',conflx
935 print *,'SMFRKEEP,KEEPFR ',smfrkeep,keepfr
936 endif
937 ENDIF
938
939 smtotold(i,j)=0.
940
941 do k=1,nroot
942 smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))* &
943 (zshalf(k+1)-zshalf(k))
944 enddo
945
946 if (debug_print .and. abs(xlat-testptlat).lt.0.2 &
947 .and. abs(xlon-testptlon).lt.0.2) then
948 print *,'Old soilm1d ',i,soilm1d
949 endif
950
951 canwatold(i,j) = canwatr
952!-----------------------------------------------------------------
953 CALL sfctmp (debug_print, dt,ktau,conflx,i,j, &
954 xlat, xlon, testptlat, testptlon, &
955!--- input variables
956 nzs,nddzs,nroot,meltfactor, & !added meltfactor
957 isncond_opt,isncovr_opt, &
958 iland,isoil,ivgtyp(i,j),isltyp(i,j), &
959 prcpms, newsnms,snwe,snhei,snowfrac, &
960 exticeden,rhosn,rhonewsn_ex(i),rhonewsn, &
961 rhosnfall,snowrat,grauprat,icerat,curat, &
962 patm,tabs,qvatm,qcatm,rho, &
963 glw(i,j),gswdn(i,j),gsw(i,j), &
964 emissl(i,j),emisbck(i,j), &
965 msnf(i,j), facsnf(i,j), &
966 qkms,tkms,pc(i,j),lmavail(i,j), &
967 canwatr,vegfra(i,j),alb(i,j),znt(i,j), &
968 snoalb(i,j),albbck(i,j),lai(i,j), &
969 hgt(i,j),stdev(i,j), & !new
970 myj,seaice(i,j),isice, &
971 add_fire_heat_flux,fire_heat_flux(i,j), &
972!--- soil fixed fields
973 qwrtz, &
974 rhocs,dqm,qmin,ref, &
975 wilt,psis,bclh,ksat, &
976 sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq, &
977!--- constants
978 cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, &
979 kqwrtz,kice,kwt, &
980!--- output variables
981 snweprint,snheiprint,rsm, &
982 soilm1d,tso1d,smfrkeep,keepfr, &
983 soilt(i,j),soilt1(i,j),tsnav(i,j),dew(i,j), &
984 qvg(i,j),qsg(i,j),qcg(i,j),smelt(i,j), &
985 snoh(i,j),snflx(i,j),snom(i,j),snowfallac(i,j), &
986 acsnow(i,j),edir(i,j),ec(i,j),ett(i,j),qfx(i,j), &
987 lh(i,j),hfx(i,j),sflx(i,j),sublim(i,j), &
988 evapl(i,j),prcpl(i,j),budget(i,j),runoff1(i,j), &
989 runoff2(i,j),soilice,soiliqw,infiltrp,smf(i,j))
990!-----------------------------------------------------------------
991
992! Fraction of cropland category in the grid box should not have soil moisture below
993! wilting point during the growing season.
994! Let's keep soil moisture 5% above wilting point for the crop fraction of grid box.
995! This change violates LSM moisture budget, but
996! can be considered as a compensation for irrigation not included into LSM.
997! "Irigation" could be applied when landuse fractional information
998! is available and mosaic_lu=1.
999 if(mosaic_lu == 1) then
1000 ! greenness factor: between 0 for min greenness and 1 for max greenness.
1001 factor = max(zero,min(one,(vegfra(i,j)-shdmin(i,j))/max(one,(shdmax(i,j)-shdmin(i,j)))))
1002 if (debug_print ) then
1003 if (abs(xlat-testptlat).lt.0.1 .and. &
1004 abs(xlon-testptlon).lt.0.1)then
1005 print *,' lat,lon=',xlat,xlon,' factor=',factor
1006 endif
1007 endif
1008
1009 if((ivgtyp(i,j) == natural .or. ivgtyp(i,j) == crop) .and. factor > 0.75) then
1010 ! cropland or grassland, apply irrigation during the growing seaspon when fraction
1011 ! of greenness is > 0.75.
1012
1013 do k=1,nroot
1014 cropsm=1.05_kind_phys*wilt - qmin
1015 cropfr = min(one,lufrac(crop) + 0.4*lufrac(natural)) ! assume that 40% of natural is cropland
1016 newsm = cropsm*cropfr + (1.-cropfr)*soilm1d(k)
1017 if(soilm1d(k) < newsm) then
1018 IF (debug_print ) THEN
1019 if (abs(xlat-testptlat).lt.0.1 .and. &
1020 abs(xlon-testptlon).lt.0.1)then
1021 print * ,'Soil moisture is below wilting in cropland areas at time step',ktau
1022 print * ,' lat,lon=',xlat,xlon
1023 print * ,' lufrac=',lufrac,'factor=',factor &
1024 ,'lai,ivgtyp,lufrac(crop),k,soilm1d(k),cropfr,wilt,cropsm,newsm,', &
1025 lai(i,j),ivgtyp(i,j),lufrac(crop),k,soilm1d(k),cropfr,wilt,cropsm,newsm
1026 endif
1027 ENDIF
1028 soilm1d(k) = newsm
1029 IF (debug_print ) THEN
1030 if (abs(xlat-testptlat).lt.0.1 .and. &
1031 abs(xlon-testptlon).lt.0.1)then
1032 print*,' lat,lon=',xlat,xlon
1033 print * ,'Added soil water to cropland areas, k,soilm1d(k)',k,soilm1d(k)
1034 endif
1035 ENDIF
1036 endif ! < cropsm
1037 enddo
1038 endif ! crop
1039 endif ! mosaic_lu
1040
1041!*** DIAGNOSTICS
1042!--- available and maximum soil moisture content in the soil
1043!--- domain
1044
1045 smavail(i,j) = zero
1046 smmax(i,j) = zero
1047
1048 !do k=1,nzs-1
1049 !-- root-zone soil moisture
1050 do k=1,nroot
1051 smavail(i,j)=smavail(i,j)+(qmin+soilm1d(k))* &
1052 (zshalf(k+1)-zshalf(k))
1053 smmax(i,j) =smmax(i,j)+(qmin+dqm)* &
1054 (zshalf(k+1)-zshalf(k))
1055 enddo
1056
1057 if (debug_print) then
1058 if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then
1059 print 100,'(RUC runoff) i=',i,' lat,lon=',xlat,xlon, &
1060 'RUNOFF1', runoff1(i,j), 'RUNOFF2 ',runoff2(i,j), &
1061 'edir ',edir(i,j),'ec ',ec(i,j),'ett ',ett(i,j)
1062 endif
1063 endif
1064!--- Convert the water unit into mm
1065 !-- three lines below are commented because accumulation
1066 ! happens in sfc_drv_ruc
1067 acrunoff(i,j) = (runoff1(i,j)+runoff2(i,j))*dt*rhowater
1068 smavail(i,j) = smavail(i,j) * rhowater ! mm
1069 smmax(i,j) = smmax(i,j) * rhowater
1070 smtotold(i,j) = smtotold(i,j) * rhowater ! mm
1071
1072 do k=1,nzs
1073
1074 soilmois(i,k,j) = soilm1d(k) + qmin
1075 sh2o(i,k,j) = min(soiliqw(k) + qmin,soilmois(i,k,j))
1076 tso(i,k,j) = tso1d(k)
1077 enddo
1078
1079 do k=1,nzs
1080 smfr3d(i,k,j) = smfrkeep(k)
1081 keepfr3dflag(i,k,j) = keepfr(k)
1082 enddo
1083
1084!tgs add together dew and cloud at the ground surface
1085!30july13 qcg(i,j)=qcg(i,j)+dew(i,j)/qkms
1086
1087 z0(i,j) = znt(i,j)
1088 sfcexc(i,j) = tkms
1089 patmb=p8w(i,1,j)*1.e-2_kind_phys
1090 q2sat=qsn(tabs,tbq)/patmb
1091 qsfc(i,j) = qvg(i,j)/(one+qvg(i,j))
1092 ! for MYJ surface and PBL scheme
1093 ! if (myj) then
1094 ! MYJSFC expects QSFC as actual specific humidity at the surface
1095 IF((qvatm.GE.q2sat*0.95_kind_phys).AND.qvatm.LT.qvg(i,j))THEN
1096 chklowq(i,j)=zero
1097 ELSE
1098 chklowq(i,j)=one
1099 ENDIF
1100
1101 if(snow(i,j)==zero) emissl(i,j) = emisbck(i,j)
1102 emiss(i,j) = emissl(i,j)
1103 ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m
1104 !-- 17 may 2024 - cap snow for points at high elevations where all year round skin temperatures are close to 0 C
1105 !-- Snow density for these points will be 3000/7.5=400 [kg/m^3]
1106 snow(i,j) = min(3._kind_phys,snwe)*1000._kind_phys ! cap to be < 3 m
1107 snowh(i,j) = min(7.5_kind_phys,snhei) ! cap to be < 7.5 m
1108 canwat(i,j) = canwatr*1000._kind_phys
1109
1110 if (debug_print) then
1111 if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then
1112 print *,'snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)',snow(i,j),soilt(i,j),xice(i,j),tso(i,:,j)
1113 endif
1114 endif
1115 infiltr(i,j) = infiltrp
1116
1117 mavail(i,j) = lmavail(i,j)
1118 IF (debug_print ) THEN
1119 if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then
1120 print *,' LAND, I=,J=, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j)
1121 endif
1122 ENDIF
1123 sfcevp(i,j) = sfcevp(i,j) + qfx(i,j) * dt
1124 grdflx(i,j) = -one * sflx(i,j)
1125
1126!tgs - SMF.NE.0. when there is phase change in the top soil layer
1127! The heat of soil water freezing/thawing is not computed explicitly
1128! and is responsible for the residual in the energy budget.
1129
1130!--- SNOWC snow cover flag
1131 snowc(i,j)=snowfrac
1132
1133!--- RHOSNF - density of snowfall
1134 rhosnf(i,j)=rhosnfall
1135
1136! Accumulated moisture flux [kg/m^2]
1137 sfcevp(i,j) = sfcevp(i,j) + qfx(i,j) * dt
1138
1139!--tgs - SMF.NE.0. when there is phase change in the top soil layer
1140! The heat of freezing/thawing of soil water is not computed explicitly
1141! and is responsible for the residual in the energy budget.
1142! endif
1143! budget(i,j)=budget(i,j)-smf(i,j)
1144
1145 if (debug_print ) then
1146 if (abs(xlat-testptlat).lt.0.2 .and. &
1147 abs(xlon-testptlon).lt.0.2)then
1148 !-- compute budget for a test point
1149 ac=zero
1150 as=zero
1151 wb=zero
1152
1153 ac=canwat(i,j)-canwatold(i,j)*rhowater ! canopy water change
1154 as=snwe-snowold(i,j) ! SWE change
1155 wb = smavail(i,j)-smtotold(i,j)
1156 waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*rhowater & ! source
1157 -qfx(i,j)*dt &
1158 -runoff1(i,j)*dt*rhowater-runoff2(i,j)*dt*rhowater &
1159 -ac-as ! - (smavail(i,j)-smtotold(i,j))
1160
1161 print *,'soilm1d ',i,soilm1d
1162 print 100,'(RUC budgets) i=',i,' lat,lon=',xlat,xlon, &
1163 'budget ',budget(i,j),'waterbudget',waterbudget(i,j), &
1164 'rainbl ',rainbl(i,j),'runoff1 ',runoff1(i,j), &
1165 'smelt ',smelt(i,j)*dt*1.e3_kind_phys,'smc change ',wb, &
1166 'snwe change ',as,'canw change ',ac,'runoff2 ',runoff2(i,j), &
1167 'qfx*dt ',qfx(i,j)*dt,'smavail ',smavail(i,j),'smcold',smtotold(i,j)
1168 !--
1169 print *,'Smf=',smf(i,j),i,j
1170 print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j)
1171 print *,'SNOW-SNOWold',i,j,max(zero,snwe-snowold(i,j))
1172 print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j)
1173 print *,'canwat(i,j)-canwatold(i,j)',max(zero,canwat(i,j)-canwatold(i,j))
1174 endif
1175 endif
1176
1177 100 format (";;; ",a,i4,a,2f14.7/(4(a10,'='es14.7)))
1178
1179
1180 IF (debug_print ) THEN
1181 if (abs(xlat-testptlat).lt.0.2 .and. &
1182 abs(xlon-testptlon).lt.0.2)then
1183 print *,'LAND, i,tso1d,soilm1d,soilt - end of time step', &
1184 i,tso1d,soilm1d,soilt(i,j)
1185 print *,'LAND, QFX, HFX after SFCTMP', i,lh(i,j),hfx(i,j)
1186 endif
1187 ENDIF
1188
1189!--- end of a land or sea ice point
1190 ENDIF
11912999 continue ! lakes
1192 ENDDO
1193
1194 ENDDO
1195
1196!-----------------------------------------------------------------
1197 END SUBROUTINE lsmruc
1198!! @}
1199!-----------------------------------------------------------------
1200
1210 SUBROUTINE sfctmp (debug_print, delt,ktau,conflx,i,j, & !--- input variables
1211 xlat,xlon,testptlat,testptlon, &
1212 nzs,nddzs,nroot,meltfactor, &
1213 isncond_opt,isncovr_opt, &
1214 ILAND,ISOIL,IVGTYP,ISLTYP,PRCPMS, &
1215 NEWSNMS,SNWE,SNHEI,SNOWFRAC, &
1216 exticeden,RHOSN,RHONEWSN_ex,RHONEWSN,RHOSNFALL, &
1217 snowrat,grauprat,icerat,curat, &
1218 PATM,TABS,QVATM,QCATM,rho, &
1219 GLW,GSWdn,GSW,EMISS,EMISBCK,msnf,facsnf, &
1220 QKMS,TKMS,PC,MAVAIL,CST,VEGFRA,ALB,ZNT, &
1221 ALB_SNOW,ALB_SNOW_FREE,lai,hgt,stdev, &
1222 MYJ,SEAICE,ISICE, &
1223 add_fire_heat_flux,fire_heat_flux, &
1224 QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields
1225 sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, &
1226 cp,rovcp,g0,lv,stbolt,cw,c1sn,c2sn, & !--- constants
1227 KQWRTZ,KICE,KWT, &
1228 snweprint,snheiprint,rsm, & !---output variables
1229 soilm1d,ts1d,smfrkeep,keepfr,soilt,soilt1, &
1230 tsnav,dew,qvg,qsg,qcg, &
1231 SMELT,SNOH,SNFLX,SNOM,SNOWFALLAC,ACSNOW, &
1232 edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, &
1233 evapl,prcpl,fltot,runoff1,runoff2,soilice, &
1234 soiliqw,infiltr,smf)
1235!-----------------------------------------------------------------
1236 IMPLICIT NONE
1237!-----------------------------------------------------------------
1238
1239!--- input variables
1240
1241 INTEGER, INTENT(IN ) :: isice,i,j,nroot,ktau,nzs , &
1242 nddzs !nddzs=2*(nzs-2)
1243 integer, intent(in ) :: isncond_opt,isncovr_opt
1244
1245 real (kind_phys), INTENT(IN ) :: delt,conflx,meltfactor,xlat,xlon
1246 real (kind_phys), INTENT(IN ) :: testptlat,testptlon
1247 real (kind_phys), INTENT(IN ) :: c1sn,c2sn,rhonewsn_ex
1248 LOGICAL, INTENT(IN ) :: myj, debug_print, exticeden
1249!--- 3-D Atmospheric variables
1250 real (kind_phys) , &
1251 INTENT(IN ) :: patm, &
1252 tabs, &
1253 qvatm, &
1254 qcatm
1255 real (kind_phys) , &
1256 INTENT(IN ) :: glw, &
1257 gsw, &
1258 gswdn, &
1259 pc, &
1260 msnf,facsnf, &
1261 vegfra, &
1262 alb_snow_free, &
1263 lai, &
1264 hgt,stdev, &
1265 seaice, &
1266 rho, &
1267 qkms, &
1268 tkms, &
1269 fire_heat_flux
1270 LOGICAL, INTENT(IN ) :: add_fire_heat_flux
1271
1272 INTEGER, INTENT(IN ) :: ivgtyp, isltyp
1273!--- 2-D variables
1274 real (kind_phys) , &
1275 INTENT(INOUT) :: emiss, &
1276 emisbck, &
1277 mavail, &
1278 snowfrac, &
1279 alb_snow, &
1280 alb, &
1281 cst
1282
1283!--- soil properties
1284 real (kind_phys) :: &
1285 rhocs, &
1286 bclh, &
1287 dqm, &
1288 ksat, &
1289 psis, &
1290 qmin, &
1291 qwrtz, &
1292 ref, &
1293 sat, &
1294 wilt
1295
1296 real (kind_phys), INTENT(IN ) :: cn, &
1297 cw, &
1298 cp, &
1299 rovcp, &
1300 g0, &
1301 lv, &
1302 stbolt, &
1303 kqwrtz, &
1304 kice, &
1305 kwt
1306
1307 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: zsmain, &
1308 zshalf, &
1309 dtdzs2
1310
1311
1312 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: dtdzs
1313
1314 real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: tbq
1315
1316
1317!--- input/output variables
1318!-------- 3-d soil moisture and temperature
1319 real (kind_phys), DIMENSION( 1:nzs ) , &
1320 INTENT(INOUT) :: ts1d, &
1321 soilm1d, &
1322 smfrkeep
1323 real (kind_phys), DIMENSION( 1:nzs ) , &
1324 INTENT(INOUT) :: keepfr
1325
1326 real (kind_phys), DIMENSION(1:NZS),INTENT(INOUT) :: soilice, &
1327 soiliqw
1328
1329
1330 INTEGER, INTENT(INOUT) :: iland,isoil
1331 INTEGER :: ilands
1332
1333!-------- 2-d variables
1334 real (kind_phys) , &
1335 INTENT(INOUT) :: dew, &
1336 edir1, &
1337 ec1, &
1338 ett1, &
1339 eeta, &
1340 evapl, &
1341 infiltr, &
1342 rhosn, &
1343 rhonewsn, &
1344 rhosnfall, &
1345 snowrat, &
1346 grauprat, &
1347 icerat, &
1348 curat, &
1349 sublim, &
1350 prcpl, &
1351 qvg, &
1352 qsg, &
1353 qcg, &
1354 qfx, &
1355 hfx, &
1356 fltot, &
1357 smf, &
1358 s, &
1359 runoff1, &
1360 runoff2, &
1361 acsnow, &
1362 snowfallac, &
1363 snwe, &
1364 snhei, &
1365 smelt, &
1366 snom, &
1367 snoh, &
1368 snflx, &
1369 soilt, &
1370 soilt1, &
1371 tsnav, &
1372 znt
1373
1374 real (kind_phys), DIMENSION(1:NZS) :: &
1375 tice, &
1376 rhosice, &
1377 capice, &
1378 thdifice, &
1379 ts1ds, &
1380 soilm1ds, &
1381 smfrkeeps, &
1382 soiliqws, &
1383 soilices, &
1384 keepfrs
1385!-------- 1-d variables
1386 real (kind_phys) :: &
1387 dews, &
1388 mavails, &
1389 edir1s, &
1390 ec1s, &
1391 csts, &
1392 ett1s, &
1393 eetas, &
1394 evapls, &
1395 infiltrs, &
1396 prcpls, &
1397 qvgs, &
1398 qsgs, &
1399 qcgs, &
1400 qfxs, &
1401 hfxs, &
1402 fltots, &
1403 runoff1s, &
1404 runoff2s, &
1405 ss, &
1406 soilts
1407
1408
1409
1410
1411 real (kind_phys), INTENT(INOUT) :: rsm, &
1412 snweprint, &
1413 snheiprint
1414!--- Local variables
1415
1416 INTEGER :: k,ilnb
1417
1418 real (kind_phys) :: bsn, xsn , &
1419 rainf, snth, newsn, prcpms, newsnms , &
1420 t3, upflux, xinet, snowfrac2, m
1421 real (kind_phys) :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, snowfracnewsn
1422 real (kind_phys) :: newsnowratio, dd1
1423
1424 real (kind_phys) :: rhonewgr,rhonewice
1425
1426 real (kind_phys) :: rnet,gswnew,gswin,emissn,zntsn,emiss_snowfree
1427 real (kind_phys) :: vegfrac, snow_mosaic, snfr, vgfr
1428 real :: cice, albice, albsn, drip, dripsn, dripliq
1429 real :: interw, intersn, infwater, intwratio
1430
1431!-----------------------------------------------------------------
1432 integer, parameter :: ilsnow=99
1433
1434 IF (debug_print ) THEN
1435 print *,' in SFCTMP',i,j,nzs,nddzs,nroot, &
1436 snwe,rhosn,snom,smelt,ts1d
1437 ENDIF
1438
1439 !-- Snow fraction options
1440 !-- option 1: original formulation using critical snow depth to compute
1441 !-- snow fraction
1442 !-- option 2: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674.
1443 !-- option 3: the tanh formulation from Niu,G.-Y.,and Yang,Z.-L. 2007,JGR,DOI:10.1029/2007JD008674.
1444 ! with vegetation dependent parameters from Noah MP (personal
1445 ! communication with Mike Barlage)
1446 !-- SNHEI_CRIT is a threshold for fractional snow in isncovr_opt=1
1447 snhei_crit=0.01601_kind_phys*rhowater/rhosn
1448 snhei_crit_newsn=0.0005_kind_phys*rhowater/rhosn
1449 !--
1450 zntsn = z0tbl(isice)
1451 snow_mosaic = zero
1452 snfr = one
1453 newsn= zero
1454 newsnowratio = zero
1455 snowfracnewsn= zero
1456 snowfrac2= zero
1457 rhonewsn = 100._kind_phys
1458 if(snhei == zero) snowfrac=zero
1459 smelt = zero
1460 rainf = zero
1461 rsm = zero
1462 dd1 = zero
1463 infiltr = zero
1464! Jul 2016 - Avissar and Pielke (1989)
1465! This formulation depending on LAI defines relative contribution of the vegetation to
1466! the total heat fluxes between surface and atmosphere.
1467! With VEGFRA=100% and LAI=3, VEGFRAC=0.86 meaning that vegetation contributes
1468! only 86% of the total surface fluxes.
1469! VGFR=0.01*VEGFRA ! % --> fraction
1470! VEGFRAC=2.*lai*vgfr/(1.+2.*lai*vgfr)
1471 vegfrac=0.01_kind_phys*vegfra
1472 drip = zero
1473 dripsn = zero
1474 dripliq = zero
1475 smf = zero
1476 interw = zero
1477 intersn = zero
1478 infwater = zero
1479
1480!---initialize local arrays for sea ice
1481 do k=1,nzs
1482 tice(k) = zero
1483 rhosice(k) = zero
1484 cice = zero
1485 capice(k) = zero
1486 thdifice(k) = zero
1487 enddo
1488
1489 gswnew=gsw
1490 gswin=gswdn !/(1.-alb)
1491 albice=alb_snow_free
1492 albsn=alb_snow
1493 emissn = 0.99_kind_phys ! from setemis, from WRF - 0.98
1494 emiss_snowfree = emisbck ! LEMITBL(IVGTYP)
1495
1496!--- sea ice properties
1497!--- N.N Zubov "Arctic Ice"
1498!--- no salinity dependence because we consider the ice pack
1499!--- to be old and to have low salinity (0.0002)
1500 if(seaice.ge.0.5_kind_phys) then
1501 do k=1,nzs
1502 tice(k) = ts1d(k) - tfrz
1503 rhosice(k) = 917.6_kind_phys/(one-0.000165_kind_phys*tice(k))
1504 cice = 2115.85_kind_phys +7.7948_kind_phys*tice(k)
1505 capice(k) = cice*rhosice(k)
1506 thdifice(k) = 2.260872_kind_phys/capice(k)
1507 enddo
1508!-- SEA ICE ALB dependence on ice temperature. When ice temperature is
1509!-- below critical value of -10C - no change to albedo.
1510!-- If temperature is higher that -10C then albedo is decreasing.
1511!-- The minimum albedo at t=0C for ice is 0.1 less.
1512 albice = min(alb_snow_free,max(alb_snow_free - 0.05_kind_phys, &
1513 alb_snow_free - 0.1_kind_phys*(tice(1)+10._kind_phys)/10._kind_phys ))
1514 endif
1515
1516 IF (debug_print ) THEN
1517 print *,'alb_snow_free',alb_snow_free
1518 print *,'GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE',&
1519 gsw,gswnew,glw,soilt,emiss,alb,albice,snwe
1520 ENDIF
1521
1522 if(snhei.gt.0.0081_kind_phys*rhowater/rhosn) then
1523!*** Update snow density for current temperature (Koren et al 1999,doi:10.1029/1999JD900232.)
1524 bsn=delt/3600._kind_phys*c1sn*exp(0.08_kind_phys*min(zero,tsnav)-c2sn*rhosn*1.e-3_kind_phys)
1525 if(bsn*snwe*100._kind_phys.ge.1.e-4_kind_phys) then
1526 xsn=rhosn*(exp(bsn*snwe*100._kind_phys)-one)/(bsn*snwe*100._kind_phys)
1527 rhosn=min(max(58.8_kind_phys,xsn),500._kind_phys)
1528 endif
1529 endif
1530
1531 !-- snow_mosaic from the previous time step
1532 if(snowfrac < 0.75_kind_phys) snow_mosaic = one
1533
1534 newsn=newsnms*delt
1535!---- ACSNOW - run-total snowfall water [mm]
1536 acsnow=acsnow+newsn*rhowater
1537
1538 IF(newsn.GT.zero) THEN
1539
1540 IF (debug_print ) THEN
1541 print *, 'THERE IS NEW SNOW, newsn', newsn
1542 ENDIF
1543
1544 newsnowratio = min(one,newsn/(snwe+newsn))
1545
1546 !if(isncovr_opt == 2) then
1547 !-- update snow fraction for fresh snowfall (Swenson&Lawrence,JGR,2012)
1548 ! time-step snowfall [mm H2O], 0.1 - accumulation constant (unitless)
1549 ! snowfrac = snowfrac + tanh(0.1*newsn*1.e3)*(1.-snowfrac) ! eq. 8.1 from CLM5
1550 ! if(debug_print) print *,'2 - snowfrac newsn', i,j,ktau,snowfrac
1551 !endif
1552
1553!--- 27 Feb 2014 - empirical formulations from John M. Brown
1554! rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333))))
1555!--- 13 Mar 2018 - formulation from Trevor Elcott
1556 if (exticeden) then
1557 rhonewsn = rhonewsn_ex
1558 else
1559 rhonewsn=min(125._kind_phys,rhowater/max(8._kind_phys,(17._kind_phys*tanh((276.65_kind_phys-tabs)*0.15_kind_phys))))
1560 rhonewgr=min(500._kind_phys,rhowater/max(2._kind_phys,(3.5_kind_phys*tanh((274.15_kind_phys-tabs)*0.3333_kind_phys))))
1561 rhonewice=rhonewsn
1562
1563!--- compute density of "snowfall" from weighted contribution
1564! of snow, graupel and ice fractions
1565
1566 rhosnfall = min(500._kind_phys,max(58.8_kind_phys,(rhonewsn*snowrat + &
1567 rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat)))
1568
1569 if (debug_print) then
1570 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
1571 print *,' xlat, xlon', xlat, xlon
1572 print *,'snow_mosaic = ',snow_mosaic
1573 print *,'new snow,newsnowratio,rhosnfall =',newsn,newsnowratio,rhosnfall
1574 print *,'snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice',snowrat,grauprat,icerat,curat,rhonewgr,rhonewsn,rhonewice
1575 endif
1576! from now on rhonewsn is the density of falling frozen precipitation
1577 rhonewsn=rhosnfall
1578 end if
1579
1580!*** Define average snow density of the snow pack considering
1581!*** the amount of fresh snow (eq. 9 in Koren et al.(1999)
1582!*** without snow melt )
1583 xsn=(rhosn*snwe+rhonewsn*newsn)/ &
1584 (snwe+newsn)
1585 rhosn=min(max(58.8_kind_phys,xsn),500._kind_phys)
1586 ENDIF ! end NEWSN > 0.
1587
1588 IF(prcpms > zero) THEN
1589
1590! PRCPMS is liquid precipitation rate
1591! RAINF is a flag used for calculation of rain water
1592! heat content contribution into heat budget equation. Rain's temperature
1593! is set equal to air temperature at the first atmospheric
1594! level.
1595
1596 rainf=one
1597 ENDIF
1598
1599 drip = zero
1600 intwratio= zero
1601 if(vegfrac > 0.01_kind_phys) then
1602! compute intercepted precipitation - Eq. 1 Lawrence et al.,
1603! J. of Hydrometeorology, 2006, CLM.
1604 interw=0.25_kind_phys*delt*prcpms*(one-exp(-0.5_kind_phys*lai))*vegfrac
1605 intersn=0.25_kind_phys*newsn*(one-exp(-0.5_kind_phys*lai))*vegfrac
1606 infwater=prcpms - interw/delt
1607 if((interw+intersn) > zero) then
1608 intwratio=interw/(interw+intersn)
1609 endif
1610
1611! Update water/snow intercepted by the canopy
1612 dd1=cst + interw + intersn
1613 cst=dd1
1614 IF(cst.GT.sat) THEN
1615 cst=sat
1616 drip=dd1-sat
1617 ENDIF
1618 else
1619 cst=zero
1620 drip=zero
1621 interw=zero
1622 intersn=zero
1623 infwater=prcpms
1624 endif ! vegfrac > 0.01
1625
1626
1627 IF(newsn.GT.zero) THEN
1628!Update snow on the ground
1629 snwe=max(zero,snwe+newsn-intersn)
1630! Add drip to snow on the ground
1631 if(drip > zero) then
1632 if (snow_mosaic==one) then
1633 dripliq=drip*intwratio
1634 dripsn = drip - dripliq
1635 snwe=snwe+dripsn
1636 infwater=infwater+dripliq
1637 dripliq=zero
1638 dripsn = zero
1639 else
1640 snwe=snwe+drip
1641 endif
1642 endif
1643 snhei=snwe*rhowater/rhosn
1644 newsn=newsn*rhowater/rhonewsn
1645 ENDIF
1646
1647 IF(snhei.GT.zero) THEN
1648!-- SNOW on the ground
1649!--- Land-use category should be changed to snow/ice for grid points with snow>0
1650 iland=isice
1651!24nov15 - based on field exp on Pleasant View soccer fields
1652! if(meltfactor > 1.5) then ! all veg. types, except forests
1653! SNHEI_CRIT=0.01601*1.e3/rhosn
1654! Petzold - 1 cm of fresh snow overwrites effects from old snow.
1655! Need to test SNHEI_CRIT_newsn=0.01
1656! SNHEI_CRIT_newsn=0.01
1657! else ! forests
1658! SNHEI_CRIT=0.02*1.e3/rhosn
1659! SNHEI_CRIT_newsn=0.001*1.e3/rhosn
1660! endif
1661
1662 !-- update snow cover with accounting for fresh snow
1663 m = one ! m=1.6 in Niu&Yang, m=1 in CLM
1664 if(isncovr_opt == 1) then
1665 snowfrac=min(one,snhei/(2._kind_phys*snhei_crit))
1666 elseif(isncovr_opt == 2) then
1667 snowfrac=min(one,snhei/(2._kind_phys*snhei_crit))
1668 if(ivgtyp == glacier .or. ivgtyp == bare) then
1669 !-- sparsely vegetated or land ice
1670 snowfrac2 = tanh( snhei/(2.5_kind_phys * 0.2_kind_phys *(rhosn/rhonewsn)**m))
1671 else
1672 !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests
1673 ! on 3-km scale use actual roughness, but not higher than 0.2 m.
1674 ! The factor is 20 for forests (~100/dx = 33.)
1675 snowfrac2 = tanh( snhei/(2.5_kind_phys *min(0.2_kind_phys,znt) *(rhosn/rhonewsn)**m))
1676 endif
1677 !-- snow fraction is average between method 1 and 2
1678 snowfrac = 0.5_kind_phys*(snowfrac+snowfrac2)
1679 else
1680 !-- isncovr_opt=3
1681 !m = msnf ! vegetation dependent facsnf/msnf from Noah MP
1682 !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of
1683 ! snow cover fractions on the 3-km scale.
1684 ! This factor is scale dependent.
1685 snowfrac = tanh( snhei/(10._kind_phys * facsnf *(rhosn/rhonewsn)**m))
1686 endif
1687
1688 if(newsn > zero ) then
1689 snowfracnewsn=min(one,snowfallac*1.e-3_kind_phys/snhei_crit_newsn)
1690 endif
1691
1692 !-- due to steep slopes and blown snow, limit snow fraction in the
1693 !-- mountains to 0.85 (based on Swiss weather model over the Alps)
1694 if(hgt > 2500._kind_phys .and. ivgtyp == glacier) snowfrac=min(0.85_kind_phys,snowfrac)
1695
1696 !24nov15 - SNOWFRAC for urban category < 0.75
1697 if(ivgtyp == urban) snowfrac=min(0.75_kind_phys,snowfrac)
1698
1699 if(snowfrac < 0.75_kind_phys) snow_mosaic = one
1700
1701 keep_snow_albedo = zero
1702 IF (snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN
1703 ! new snow
1704 keep_snow_albedo = one
1705 ! turn off separate treatment of snow covered and snow-free portions of the grid cell
1706 snow_mosaic=0. ! ???
1707 ENDIF
1708
1709 IF (debug_print ) THEN
1710 print *,'SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn', &
1711 snhei_crit,snowfrac,snhei_crit_newsn,snowfracnewsn
1712 ENDIF
1713
1714!-- Set znt for snow from VEGPARM table (snow/ice landuse), except for
1715!-- land-use types with higher roughness (forests, urban).
1716 IF(newsn.eq.zero .and. znt.le.0.2_kind_phys .and. ivgtyp.ne.isice) then
1717 if( snhei .le. 2._kind_phys*znt)then
1718 ! shallow snow
1719 znt=0.55_kind_phys*znt+0.45_kind_phys*z0tbl(iland)
1720 elseif( snhei .gt. 2._kind_phys*znt .and. snhei .le. 4._kind_phys*znt)then
1721 znt=0.2_kind_phys*znt+0.8_kind_phys*z0tbl(iland)
1722 elseif(snhei > 4._kind_phys*znt) then
1723 ! deep snow
1724 znt=z0tbl(iland)
1725 endif
1726 ENDIF
1727
1728
1729 IF(seaice .LT. 0.5_kind_phys) THEN
1730!----- SNOW on soil
1731!-- ALB dependence on snow depth
1732! ALB_SNOW across Canada's forested areas is very low - 0.27-0.35, this
1733! causes significant warm biases. Limiting ALB in these areas to be higher than 0.4
1734! hwlps with these biases..
1735 if( snow_mosaic == one) then
1736 albsn=alb_snow
1737 if(keep_snow_albedo > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then
1738 !-- Albedo correction with fresh snow and deep snow pack
1739 !-- will reduce warm bias in western Canada
1740 !-- and US West coast, where max snow albedo is low (0.3-0.5).
1741 !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j
1742 albsn = 0.7_kind_phys
1743 endif
1744
1745 emiss= emissn
1746 else
1747 albsn = max(keep_snow_albedo*alb_snow, &
1748 min((alb_snow_free + &
1749 (alb_snow - alb_snow_free) * snowfrac), alb_snow))
1750 if(newsn > zero .and. keep_snow_albedo > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then
1751 !-- Albedo correction with fresh snow and deep snow pack
1752 !-- will reduce warm bias in western Canada
1753 !-- and US West coast, where max snow albedo is low (0.3-0.5).
1754 !print *,'ALB increase to 0.7',alb_snow,snhei,snhei_crit,albsn,i,j
1755 albsn = 0.7_kind_phys
1756 !print *,'NO mosaic ALB increase to 0.7',alb_snow,snhei,snhei_crit,alb,i,j
1757 endif
1758
1759 emiss = max(keep_snow_albedo*emissn, &
1760 min((emiss_snowfree + &
1761 (emissn - emiss_snowfree) * snowfrac), emissn))
1762 endif ! snow_mosaic
1763
1764 IF (debug_print ) THEN
1765 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
1766 print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,albsn,emiss,snow_mosaic
1767 ENDIF
1768!28mar11 if canopy is covered with snow to 95% of its capacity and snow depth is
1769! higher than patchy snow treshold - then snow albedo is not less than 0.55
1770! (inspired by the flight from Fairbanks to Seatle)
1771
1772!-- ALB dependence on snow temperature. When snow temperature is
1773!-- below critical value of -10C - no change to albedo.
1774!-- If temperature is higher that -10C then albedo is decreasing.
1775!-- The minimum albedo at t=0C for snow on land is 15% less than
1776!-- albedo of temperatures below -10C.
1777 if(albsn.lt.0.4_kind_phys .or. keep_snow_albedo==1) then
1778 alb=albsn
1779 else
1780!-- change albedo when no fresh snow and snow albedo is higher than 0.5
1781 alb = min(albsn,max(albsn - 0.1_kind_phys*(soilt - 263.15_kind_phys)/ &
1782 (tfrz-263.15_kind_phys)*albsn, albsn - 0.05_kind_phys))
1783 endif
1784 ELSE
1785!----- SNOW on ice
1786 if( snow_mosaic == one) then
1787 albsn=alb_snow
1788 emiss= emissn
1789 else
1790 albsn = max(keep_snow_albedo*alb_snow, &
1791 min((albice + (alb_snow - albice) * snowfrac), alb_snow))
1792 emiss = max(keep_snow_albedo*emissn, &
1793 !-- emiss_snowfree=0.96 in setemis
1794 min((emiss_snowfree + &
1795 (emissn - emiss_snowfree) * snowfrac), emissn))
1796 endif
1797
1798 IF (debug_print ) THEN
1799 print *,'Snow on ice snow_mosaic,ALBsn,emiss',i,j,albsn,emiss,snow_mosaic
1800 ENDIF
1801!-- ALB dependence on snow temperature. When snow temperature is
1802!-- below critical value of -10C - no change to albedo.
1803!-- If temperature is higher that -10C then albedo is decreasing.
1804 if(albsn.lt.alb_snow .or. keep_snow_albedo .eq.one)then
1805 alb=albsn
1806 else
1807!-- change albedo when no fresh snow
1808 alb = min(albsn,max(albsn - 0.15_kind_phys*albsn*(soilt - 263.15_kind_phys)/ &
1809 (tfrz-263.15_kind_phys), albsn - 0.1_kind_phys))
1810 endif
1811
1812 ENDIF
1813
1814 if (snow_mosaic==one) then
1815!may 2014 - treat separately snow-free and snow-covered areas
1816
1817 if(seaice .LT. 0.5_kind_phys) then
1818! LAND
1819! portion not covered with snow
1820! compute absorbed GSW for snow-free portion
1821
1822 gswnew=gswin*(one-alb_snow_free)
1823!--------------
1824 t3 = stbolt*soilt*soilt*soilt
1825 upflux = t3 *soilt
1826 xinet = emiss_snowfree*(glw-upflux)
1827 rnet = gswnew + xinet
1828 IF ( add_fire_heat_flux .and. fire_heat_flux >0 ) then ! JLS
1829 IF (debug_print ) THEN
1830 print *,'RNET snow-free, fire_heat_flux, xlat/xlon',rnet, fire_heat_flux,xlat,xlon
1831 ENDIF
1832 rnet = rnet + fire_heat_flux
1833 ENDIF
1834
1835 IF (debug_print ) THEN
1836 print *,'Fractional snow - snowfrac=',snowfrac
1837 print *,'Snowfrac<1 GSWin,GSWnew -',gswin,gswnew,'SOILT, RNET',soilt,rnet
1838 ENDIF
1839 do k=1,nzs
1840 soilm1ds(k) = soilm1d(k)
1841 ts1ds(k) = ts1d(k)
1842 smfrkeeps(k) = smfrkeep(k)
1843 keepfrs(k) = keepfr(k)
1844 soilices(k) = soilice(k)
1845 soiliqws(k) = soiliqw(k)
1846 enddo
1847 soilts = soilt
1848 qvgs = qvg
1849 qsgs = qsg
1850 qcgs = qcg
1851 csts = cst
1852 mavails = mavail
1853 smelt=zero
1854 runoff1s=zero
1855 runoff2s=zero
1856
1857 ilands = ivgtyp
1858
1859 CALL soil(debug_print,xlat, xlon, testptlat, testptlon,&
1860!--- input variables
1861 i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, &
1862 prcpms,rainf,patm,qvatm,qcatm,glw,gswnew,gswin, &
1863 emiss_snowfree,rnet,qkms,tkms,pc,csts,dripliq, &
1864 infwater,rho,vegfrac,lai,myj, &
1865!--- soil fixed fields
1866 qwrtz,rhocs,dqm,qmin,ref,wilt, &
1867 psis,bclh,ksat,sat,cn, &
1868 zsmain,zshalf,dtdzs,dtdzs2,tbq, &
1869!--- constants
1870 lv,cp,rovcp,g0,cw,stbolt,tabs, &
1871 kqwrtz,kice,kwt, &
1872!--- output variables for snow-free portion
1873 soilm1ds,ts1ds,smfrkeeps,keepfrs, &
1874 dews,soilts,qvgs,qsgs,qcgs,edir1s,ec1s, &
1875 ett1s,eetas,qfxs,hfxs,ss,evapls,prcpls,fltots,runoff1s, &
1876 runoff2s,mavails,soilices,soiliqws, &
1877 infiltrs,smf)
1878 else
1879! SEA ICE
1880! portion not covered with snow
1881! compute absorbed GSW for snow-free portion
1882
1883 gswnew=gswin*(one-albice)
1884!--------------
1885 t3 = stbolt*soilt*soilt*soilt
1886 upflux = t3 *soilt
1887 xinet = emiss_snowfree*(glw-upflux)
1888 rnet = gswnew + xinet
1889 IF (debug_print ) THEN
1890 print *,'Fractional snow - snowfrac=',snowfrac
1891 print *,'Snowfrac<1 GSWin,GSWnew -',gswin,gswnew,'SOILT, RNET',soilt,rnet
1892 ENDIF
1893 do k=1,nzs
1894 ts1ds(k) = ts1d(k)
1895 enddo
1896 soilts = soilt
1897 qvgs = qvg
1898 qsgs = qsg
1899 qcgs = qcg
1900 smelt=zero
1901 runoff1s=zero
1902 runoff2s=zero
1903
1904 CALL sice(debug_print,xlat,xlon, &
1905!--- input variables
1906 i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, &
1907 prcpms,rainf,patm,qvatm,qcatm,glw,gswnew, &
1908 0.98_kind_phys,rnet,qkms,tkms,rho,myj, &
1909!--- sea ice parameters
1910 tice,rhosice,capice,thdifice, &
1911 zsmain,zshalf,dtdzs,dtdzs2,tbq, &
1912!--- constants
1913 lv,cp,rovcp,cw,stbolt,tabs, &
1914!--- output variable
1915 ts1ds,dews,soilts,qvgs,qsgs,qcgs, &
1916 eetas,qfxs,hfxs,ss,evapls,prcpls,fltots &
1917 )
1918 edir1 = eeta*1.e-3_kind_phys
1919 ec1 = zero
1920 ett1 = zero
1921 runoff1 = prcpms
1922 runoff2 = zero
1923 mavail = one
1924 infiltr= zero
1925 cst= zero
1926 do k=1,nzs
1927 soilm1d(k)=one
1928 soiliqw(k)=zero
1929 soilice(k)=one
1930 smfrkeep(k)=one
1931 keepfr(k)=zero
1932 enddo
1933 endif ! seaice < 0.5
1934
1935 endif ! snow_mosaic=1.
1936
1937!--- recompute absorbed solar radiation and net radiation
1938!--- for updated value of snow albedo - ALB
1939 gswnew=gswin*(one-alb)
1940!--------------
1941 t3 = stbolt*soilt*soilt*soilt
1942 upflux = t3 *soilt
1943 xinet = emiss*(glw-upflux)
1944 rnet = gswnew + xinet
1945 IF (debug_print ) THEN
1946 !if (abs(xlat-testptlat).lt.0.1 .and. abs(xlon-testptlon).lt.0.1)then
1947 print *,'RNET=',rnet
1948 print *,'SNOW - I,J,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB',&
1949 i,j,newsn,snwe,snhei,gsw,gswnew,glw,upflux,alb
1950 print *,'GSWnew',gswnew,'alb=',alb
1951 ENDIF
1952
1953 if (seaice .LT. 0.5_kind_phys) then
1954! LAND
1955 IF ( add_fire_heat_flux .and. fire_heat_flux>0 ) then ! JLS
1956 IF (debug_print ) THEN
1957 print *,'RNET snow, fire_heat_flux, xlat/xlon',rnet, fire_heat_flux,xlat,xlon
1958 ENDIF
1959 rnet = rnet + fire_heat_flux
1960 ENDIF
1961 if(snow_mosaic==one)then
1962 snfr=one
1963 else
1964 snfr=snowfrac
1965 endif
1966 CALL snowsoil (debug_print,xlat,xlon,testptlat,testptlon, & !--- input variables
1967 i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, &
1968 isncond_opt,isncovr_opt, &
1969 meltfactor,rhonewsn,snhei_crit, & ! new
1970 iland,prcpms,rainf,newsn,snhei,snwe,snfr, &
1971 rhosn,patm,qvatm,qcatm, &
1972 glw,gswnew,gswin,emiss,rnet,ivgtyp, &
1973 qkms,tkms,pc,cst,dripsn,infwater, &
1974 rho,vegfrac,alb,znt,lai, &
1975 myj, &
1976!--- soil fixed fields
1977 qwrtz,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, &
1978 sat,cn,zsmain,zshalf,dtdzs,dtdzs2,tbq, &
1979!--- constants
1980 lv,cp,rovcp,g0,cw,stbolt,tabs, &
1981 kqwrtz,kice,kwt, &
1982!--- output variables
1983 ilnb,snweprint,snheiprint,rsm, &
1984 soilm1d,ts1d,smfrkeep,keepfr, &
1985 dew,soilt,soilt1,tsnav,qvg,qsg,qcg, &
1986 smelt,snoh,snflx,snom,edir1,ec1,ett1,eeta, &
1987 qfx,hfx,s,sublim,prcpl,fltot,runoff1,runoff2, &
1988 mavail,soilice,soiliqw,infiltr )
1989 else
1990! SEA ICE
1991 if(snow_mosaic==one)then
1992 snfr=one
1993 else
1994 snfr=snowfrac
1995 endif
1996
1997 CALL snowseaice (debug_print,xlat,xlon, &
1998 i,j,isoil,delt,ktau,conflx,nzs,nddzs, &
1999 isncond_opt,isncovr_opt, &
2000 meltfactor,rhonewsn,snhei_crit, & ! new
2001 iland,prcpms,rainf,newsn,snhei,snwe,snfr, &
2002 rhosn,patm,qvatm,qcatm, &
2003 glw,gswnew,emiss,rnet, &
2004 qkms,tkms,rho,myj, &
2005!--- sea ice parameters
2006 alb,znt, &
2007 tice,rhosice,capice,thdifice, &
2008 zsmain,zshalf,dtdzs,dtdzs2,tbq, &
2009!--- constants
2010 lv,cp,rovcp,cw,stbolt,tabs, &
2011!--- output variables
2012 ilnb,snweprint,snheiprint,rsm,ts1d, &
2013 dew,soilt,soilt1,tsnav,qvg,qsg,qcg, &
2014 smelt,snoh,snflx,snom,eeta, &
2015 qfx,hfx,s,sublim,prcpl,fltot &
2016 )
2017 edir1 = eeta*1.e-3_kind_phys
2018 ec1 = zero
2019 ett1 = zero
2020 runoff1 = smelt
2021 runoff2 = zero
2022 mavail = one
2023 infiltr = zero
2024 cst = zero
2025 do k=1,nzs
2026 soilm1d(k)=one
2027 soiliqw(k)=zero
2028 soilice(k)=one
2029 smfrkeep(k)=one
2030 keepfr(k)=zero
2031 enddo
2032 endif
2033
2034
2035 if (snow_mosaic==one) then
2036! May 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist,
2037! etc.
2038 if(seaice .LT. 0.5_kind_phys) then
2039! LAND
2040 IF (debug_print ) THEN
2041 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
2042 print *,' xlat, xlon', xlat, xlon
2043 print *,' snowfrac = ',snowfrac
2044 print *,' SOILT snow on land', ktau, i,j,soilt
2045 print *,' SOILT on snow-free land', i,j,soilts
2046 print *,' ts1d,ts1ds',i,j,ts1d,ts1ds
2047 print *,' SNOW flux',i,j, snflx
2048 print *,' Ground flux on snow-covered land',i,j, s
2049 print *,' Ground flux on snow-free land', i,j,ss
2050 print *,' CSTS, CST', i,j,csts,cst
2051 ENDIF
2052
2053 do k=1,nzs
2054 soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac
2055 ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac
2056 smfrkeep(k) = smfrkeeps(k)*(1.-snowfrac) + smfrkeep(k)*snowfrac
2057 if(snowfrac > 0.5_kind_phys) then
2058 keepfr(k) = keepfr(k)
2059 else
2060 keepfr(k) = keepfrs(k)
2061 endif
2062 soilice(k) = soilices(k)*(1.-snowfrac) + soilice(k)*snowfrac
2063 soiliqw(k) = soiliqws(k)*(1.-snowfrac) + soiliqw(k)*snowfrac
2064 enddo
2065 dew = dews*(one-snowfrac) + dew*snowfrac
2066 soilt = soilts*(one-snowfrac) + soilt*snowfrac
2067 qvg = qvgs*(one-snowfrac) + qvg*snowfrac
2068 qsg = qsgs*(one-snowfrac) + qsg*snowfrac
2069 qcg = qcgs*(one-snowfrac) + qcg*snowfrac
2070 edir1 = edir1s*(one-snowfrac) + edir1*snowfrac
2071 ec1 = ec1s*(one-snowfrac) + ec1*snowfrac
2072 cst = csts*(one-snowfrac) + cst*snowfrac
2073 ett1 = ett1s*(one-snowfrac) + ett1*snowfrac
2074 eeta = eetas*(one-snowfrac) + eeta*snowfrac
2075 qfx = qfxs*(one-snowfrac) + qfx*snowfrac
2076 hfx = hfxs*(one-snowfrac) + hfx*snowfrac
2077 s = ss*(one-snowfrac) + s*snowfrac
2078 evapl = evapls*(one-snowfrac)
2079 prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac
2080 fltot = fltots*(one-snowfrac) + fltot*snowfrac
2081 alb = max(keep_snow_albedo*alb, &
2082 min((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb))
2083
2084 emiss = max(keep_snow_albedo*emissn, &
2085 min((emiss_snowfree + &
2086 (emissn - emiss_snowfree) * snowfrac), emissn))
2087
2088 runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac
2089 runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac
2090 mavail = mavails*(one-snowfrac) + one*snowfrac
2091 infiltr = infiltrs*(one-snowfrac) + infiltr*snowfrac
2092
2093 IF (debug_print ) THEN
2094 !if (abs(xlat-33.35).lt.0.2 .and. & abs(xlon-272.55).lt.0.2)then
2095 print *,' Ground flux combined', xlat,xlon, s
2096 print *,' SOILT combined on land', soilt
2097 print *,' TS combined on land', ts1d
2098 ENDIF
2099 else
2100! SEA ICE
2101! Now combine fluxes for snow-free sea ice and snow-covered area
2102 IF (debug_print ) THEN
2103 print *,'SOILT snow on ice', soilt
2104 ENDIF
2105 do k=1,nzs
2106 ts1d(k) = ts1ds(k)*(one-snowfrac) + ts1d(k)*snowfrac
2107 enddo
2108 dew = dews*(one-snowfrac) + dew*snowfrac
2109 soilt = soilts*(one-snowfrac) + soilt*snowfrac
2110 qvg = qvgs*(one-snowfrac) + qvg*snowfrac
2111 qsg = qsgs*(one-snowfrac) + qsg*snowfrac
2112 qcg = qcgs*(one-snowfrac) + qcg*snowfrac
2113 sublim = eeta
2114 eeta = eetas*(one-snowfrac) + eeta*snowfrac
2115 qfx = qfxs*(one-snowfrac) + qfx*snowfrac
2116 hfx = hfxs*(one-snowfrac) + hfx*snowfrac
2117 s = ss*(one-snowfrac) + s*snowfrac
2118 prcpl = prcpls*(one-snowfrac) + prcpl*snowfrac
2119 fltot = fltots*(one-snowfrac) + fltot*snowfrac
2120 alb = max(keep_snow_albedo*alb, &
2121 min((albice + (alb - alb_snow_free) * snowfrac), alb))
2122 emiss = max(keep_snow_albedo*emissn, &
2123 min((emiss_snowfree + &
2124 (emissn - emiss_snowfree) * snowfrac), emissn))
2125 runoff1 = runoff1s*(one-snowfrac) + runoff1*snowfrac
2126 runoff2 = runoff2s*(one-snowfrac) + runoff2*snowfrac
2127 IF (debug_print ) THEN
2128 print *,'SOILT combined on ice', soilt
2129 ENDIF
2130 endif
2131 endif ! snow_mosaic = 1.
2132
2133 !-- 13 jan 2022
2134 ! update snow fraction after melting (Swenson, S.C. and Lawrence, 2012,
2135 ! JGR, DOI:10.1029/2012MS000165
2136 !
2137 !if (snwe > 0.) then
2138 ! if(smelt > 0.) then
2139 !update snow fraction after melting
2140 !n_melt = 200./max(10.,topo_std)
2141 ! snowfrac = max(0.,snowfrac - (acos(min(1.,(2.*(smelt*delt/snwe) -
2142 ! 1.)))/piconst)**10)
2143 !snowfrac = 1. - (acos(min(1.,(2.*(smelt*delt/snwe) -
2144 !1.)))/piconst)**10.
2145 ! if(i==744.and.j==514 .or. i==924.and.j==568)then
2146 !print *,'smr,n_melt,topo_std', smr,n_melt,topo_std
2147 ! print *,'3 - snowfrac end', i,j,ktau,snowfrac,smelt*delt, snwe,
2148 ! piconst
2149 ! endif
2150 ! endif
2151 !else
2152 ! snowfrac = 0.
2153 !endif
2154 !
2155 !-- The NY07 parameterization gives more realistic snow cover fraction
2156 ! than SL12
2157 !-- 13 Jan 2022
2158 !-- update snow fraction after metlting (Niu, G.-Y., and Yang, Z.-L. 2007,
2159 !JGR,
2160 ! DOI:10.1029/2007JD008674)
2161 ! Limit on znt (<0.25) is needed to avoid very small snow fractions in the
2162 ! forested areas with large roughness
2163
2164 IF(snhei == zero) then
2165 !--- all snow is melted
2166 iland=ivgtyp
2167 snowfrac = zero
2168 alb = alb_snow_free
2169 emiss = emiss_snowfree
2170 ELSE
2171 !-- update snow cover after possible melting
2172 m = one ! m=1.6_kind_phys in Niu&Yang, m=1 in CLM
2173 if(isncovr_opt == 1) then
2174 snowfrac=min(one,snhei/(2._kind_phys*snhei_crit))
2175 elseif(isncovr_opt == 2) then
2176 !-- isncovr_opt=2
2177 snowfrac=min(one,snhei/(2._kind_phys*snhei_crit))
2178 if(ivgtyp == glacier .or. ivgtyp == bare) then
2179 !-- sparsely vegetated or land ice
2180 snowfrac2 = tanh( snhei/(2.5_kind_phys * 0.2_kind_phys *(rhosn/rhonewsn)**m))
2181 else
2182 !-- Niu&Yang: znt=0.01 m for 1 degree (100km) resolution tests
2183 ! on 3-km scale use actual roughness, but not higher than 0.2 m.
2184 ! The factor is 20 for forests (~100/dx = 33.)
2185 snowfrac2 = tanh( snhei/(2.5 *min(0.2,znt) *(rhosn/rhonewsn)**m))
2186 endif
2187 !-- snow fraction is average between method 1 and 2
2188 snowfrac = 0.5_kind_phys*(snowfrac+snowfrac2)
2189 else
2190 !-- isncovr_opt=3
2191 !m = msnf ! vegetation dependent facsnf/msnf from Noah MP
2192 !-- for RRFS a factor 10. was added to 'facsnf' to get reasonal values of
2193 ! snow cover fractions on the 3-km scale.
2194 ! This factor is scale dependent.
2195 snowfrac = tanh( snhei/(10._kind_phys * facsnf *(rhosn/rhonewsn)**m))
2196 endif
2197
2198 !-- due to steep slopes and blown snow, limit snow fraction in the
2199 !-- mountains ( Swiss weather model)
2200 if(hgt > 2500._kind_phys .and. ivgtyp == glacier) snowfrac=min(0.85_kind_phys,snowfrac)
2201
2202 if(ivgtyp == urban) snowfrac=min(0.75_kind_phys,snowfrac)
2203
2204! run-total accumulated snow based on snowfall and snowmelt in [mm]
2205
2206 IF (debug_print ) then
2207 !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then
2208 print *,'Snowfallac xlat, xlon',xlat,xlon
2209 print *,'newsn [m],rhonewsn,newsnowratio=',newsn,rhonewsn,newsnowratio
2210 print *,'Time-step newsn depth [m], swe [m]',newsn,newsn*rhonewsn
2211 print *,'Time-step smelt: swe [m]' ,smelt*delt
2212 print *,'Time-step sublim: swe,[kg m-2]',sublim*delt
2213 endif
2214
2215 snowfallac = snowfallac + newsn * 1.e3_kind_phys ! accumulated snow depth [mm], using variable snow density
2216
2217 IF (debug_print ) THEN
2218 !if (abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2)then
2219 print *,'snowfallac,snhei,snwe',snowfallac,snhei,snwe
2220 endif
2221 ENDIF
2222
2223 ELSE
2224!--- no snow
2225 snheiprint=zero
2226 snweprint=zero
2227 smelt=zero
2228
2229!--------------
2230 t3 = stbolt*soilt*soilt*soilt
2231 upflux = t3 *soilt
2232 xinet = emiss*(glw-upflux)
2233 rnet = gswnew + xinet
2234 IF (debug_print ) THEN
2235 print *,'NO snow on the ground GSWnew -',gswnew,'RNET=',rnet
2236 ENDIF
2237
2238 if(seaice .LT. 0.5_kind_phys) then
2239! LAND
2240 IF ( add_fire_heat_flux .and. fire_heat_flux>0) then ! JLS
2241 IF (debug_print ) THEN
2242 print *,'RNET no snow, fire_heat_flux, xlat/xlon',rnet, fire_heat_flux,xlat,xlon
2243 endif
2244 rnet = rnet + fire_heat_flux
2245 ENDIF
2246
2247 CALL soil(debug_print,xlat, xlon, testptlat, testptlon,&
2248!--- input variables
2249 i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, &
2250 prcpms,rainf,patm,qvatm,qcatm,glw,gswnew,gswin, &
2251 emiss,rnet,qkms,tkms,pc,cst,drip,infwater, &
2252 rho,vegfrac,lai,myj, &
2253!--- soil fixed fields
2254 qwrtz,rhocs,dqm,qmin,ref,wilt, &
2255 psis,bclh,ksat,sat,cn, &
2256 zsmain,zshalf,dtdzs,dtdzs2,tbq, &
2257!--- constants
2258 lv,cp,rovcp,g0,cw,stbolt,tabs, &
2259 kqwrtz,kice,kwt, &
2260!--- output variables
2261 soilm1d,ts1d,smfrkeep,keepfr, &
2262 dew,soilt,qvg,qsg,qcg,edir1,ec1, &
2263 ett1,eeta,qfx,hfx,s,evapl,prcpl,fltot,runoff1, &
2264 runoff2,mavail,soilice,soiliqw, &
2265 infiltr,smf)
2266 else
2267! SEA ICE
2268! If current ice albedo is not the same as from the previous time step, then
2269! update GSW, ALB and RNET for surface energy budget
2270 if(alb.ne.albice) gswnew=gsw/(one-alb)*(one-albice)
2271 alb=albice
2272 rnet = gswnew + xinet
2273
2274 CALL sice(debug_print,xlat,xlon, &
2275!--- input variables
2276 i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, &
2277 prcpms,rainf,patm,qvatm,qcatm,glw,gswnew, &
2278 emiss,rnet,qkms,tkms,rho,myj, &
2279!--- sea ice parameters
2280 tice,rhosice,capice,thdifice, &
2281 zsmain,zshalf,dtdzs,dtdzs2,tbq, &
2282!--- constants
2283 lv,cp,rovcp,cw,stbolt,tabs, &
2284!--- output variables
2285 ts1d,dew,soilt,qvg,qsg,qcg, &
2286 eeta,qfx,hfx,s,evapl,prcpl,fltot &
2287 )
2288 edir1 = eeta*1.e-3_kind_phys
2289 ec1 = zero
2290 ett1 = zero
2291 runoff1 = prcpms
2292 runoff2 = zero
2293 mavail = one
2294 infiltr = zero
2295 cst = zero
2296 do k=1,nzs
2297 soilm1d(k)= one
2298 soiliqw(k)= zero
2299 soilice(k)= one
2300 smfrkeep(k)= one
2301 keepfr(k)= zero
2302 enddo
2303 endif
2304
2305 ENDIF
2306
2307!---------------------------------------------------------------
2308 END SUBROUTINE sfctmp
2309!---------------------------------------------------------------
2310
2314 FUNCTION qsn(TN,T)
2315!****************************************************************
2316 real (kind_phys), DIMENSION(1:5001), INTENT(IN ) :: t
2317 real (kind_phys), INTENT(IN ) :: tn
2318
2319 real (kind_phys) qsn, r,r1,r2
2320 INTEGER i
2321
2322 r=(tn-173.15_kind_dbl_prec)/.05_kind_dbl_prec+one
2323 i=int(r)
2324
2325 if (i .LT. 1) then
2326 i = 1
2327 r = 1._kind_dbl_prec
2328 else if (i .GT. 5000) then
2329 i = 5000
2330 r = 5001._kind_dbl_prec
2331 end if
2332 r1=t(i)
2333 r2=r-i
2334 qsn=(t(i+1)-r1)*r2 + r1
2335!-----------------------------------------------------------------------
2336 END FUNCTION qsn
2337!------------------------------------------------------------------------
2338
2342 SUBROUTINE soil (debug_print,xlat,xlon,testptlat,testptlon,&
2343 i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& !--- input variables
2344 PRCPMS,RAINF,PATM,QVATM,QCATM, &
2345 GLW,GSW,GSWin,EMISS,RNET, &
2346 QKMS,TKMS,PC,cst,drip,infwater,rho,vegfrac,lai, &
2347 myj, &
2348 QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & !--- soil fixed fields
2349 sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, &
2350 xlv,CP,rovcp,G0_P,cw,stbolt,TABS, & !--- constants
2351 KQWRTZ,KICE,KWT, &
2352 soilmois,tso,smfrkeep,keepfr, & !--- output variables
2353 dew,soilt,qvg,qsg,qcg, &
2354 edir1,ec1,ett1,eeta,qfx,hfx,s,evapl, &
2355 prcpl,fltot,runoff1,runoff2,mavail,soilice, &
2356 soiliqw,infiltrp,smf)
2357
2358!*************************************************************
2359! Energy and moisture budget for vegetated surfaces
2360! without snow, heat diffusion and Richards eqns. in
2361! soil
2362!
2363! DELT - time step (s)
2364! ktau - number of time step
2365! CONFLX - depth of constant flux layer (m)
2366! J,I - the location of grid point
2367! IME, JME, KME, NZS - dimensions of the domain
2368! NROOT - number of levels within the root zone
2369! PRCPMS - precipitation rate in m/s
2370! PATM - pressure [bar]
2371! QVATM,QCATM - cloud and water vapor mixing ratio (kg/kg)
2372! at the first atm. level
2373! GLW, GSW - incoming longwave and absorbed shortwave
2374! radiation at the surface (W/m^2)
2375! EMISS,RNET - emissivity of the ground surface (0-1) and net
2376! radiation at the surface (W/m^2)
2377! QKMS - exchange coefficient for water vapor in the
2378! surface layer (m/s)
2379! TKMS - exchange coefficient for heat in the surface
2380! layer (m/s)
2381! PC - plant coefficient (resistance) (0-1)
2382! RHO - density of atmosphere near sueface (kg/m^3)
2383! VEGFRAC - greeness fraction
2384! RHOCS - volumetric heat capacity of dry soil
2385! DQM, QMIN - porosity minus residual soil moisture QMIN (m^3/m^3)
2386! REF, WILT - field capacity soil moisture and the
2387! wilting point (m^3/m^3)
2388! PSIS - matrix potential at saturation (m)
2389! BCLH - exponent for Clapp-Hornberger parameterization
2390! KSAT - saturated hydraulic conductivity (m/s)
2391! SAT - maximum value of water intercepted by canopy (m)
2392! CN - exponent for calculation of canopy water
2393! ZSMAIN - main levels in soil (m)
2394! ZSHALF - middle of the soil layers (m)
2395! DTDZS,DTDZS2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil
2396! TBQ - table to define saturated mixing ration
2397! of water vapor for given temperature and pressure
2398! SOILMOIS,TSO - soil moisture (m^3/m^3) and temperature (K)
2399! DEW - dew in kg/m^2s
2400! SOILT - skin temperature (K)
2401! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of
2402! water vapor and cloud at the ground
2403! surface, respectively (kg/kg)
2404! EDIR1, EC1, ETT1, EETA - direct evaporation, evaporation of
2405! canopy water, transpiration in kg m-2 s-1 and total
2406! evaporation in m s-1.
2407! QFX, HFX - latent and sensible heat fluxes (W/m^2)
2408! S - soil heat flux in the top layer (W/m^2)
2409! RUNOFF - surface runoff (m/s)
2410! RUNOFF2 - underground runoff (m)
2411! MAVAIL - moisture availability in the top soil layer (0-1)
2412! INFILTRP - infiltration flux from the top of soil domain (m/s)
2413!
2414!*****************************************************************
2415 IMPLICIT NONE
2416!-----------------------------------------------------------------
2417
2418!--- input variables
2419
2420 LOGICAL, INTENT(IN ) :: debug_print
2421 INTEGER, INTENT(IN ) :: nroot,ktau,nzs , &
2422 nddzs !nddzs=2*(nzs-2)
2423 INTEGER, INTENT(IN ) :: i,j,iland,isoil
2424 real (kind_phys), INTENT(IN ) :: delt,conflx
2425 real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon
2426 LOGICAL, INTENT(IN ) :: myj
2427!--- 3-D Atmospheric variables
2428 real (kind_phys), &
2429 INTENT(IN ) :: patm, &
2430 qvatm, &
2431 qcatm
2432!--- 2-D variables
2433 real (kind_phys), &
2434 INTENT(IN ) :: glw, &
2435 gsw, &
2436 gswin, &
2437 emiss, &
2438 rho, &
2439 pc, &
2440 vegfrac, &
2441 lai, &
2442 infwater, &
2443 qkms, &
2444 tkms
2445
2446!--- soil properties
2447 real (kind_phys), &
2448 INTENT(IN ) :: rhocs, &
2449 bclh, &
2450 dqm, &
2451 ksat, &
2452 psis, &
2453 qmin, &
2454 qwrtz, &
2455 ref, &
2456 wilt
2457
2458 real (kind_phys), INTENT(IN ) :: cn, &
2459 cw, &
2460 kqwrtz, &
2461 kice, &
2462 kwt, &
2463 xlv, &
2464 g0_p
2465
2466
2467 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: zsmain, &
2468 zshalf, &
2469 dtdzs2
2470
2471 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: dtdzs
2472
2473 real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: tbq
2474
2475
2476!--- input/output variables
2477!-------- 3-d soil moisture and temperature
2478 real (kind_phys), DIMENSION( 1:nzs ) , &
2479 INTENT(INOUT) :: tso, &
2480 soilmois, &
2481 smfrkeep
2482
2483 real (kind_phys), DIMENSION( 1:nzs ) , &
2484 INTENT(INOUT) :: keepfr
2485
2486!-------- 2-d variables
2487 real (kind_phys), &
2488 INTENT(INOUT) :: dew, &
2489 cst, &
2490 drip, &
2491 edir1, &
2492 ec1, &
2493 ett1, &
2494 eeta, &
2495 evapl, &
2496 prcpl, &
2497 mavail, &
2498 qvg, &
2499 qsg, &
2500 qcg, &
2501 rnet, &
2502 qfx, &
2503 hfx, &
2504 s, &
2505 sat, &
2506 runoff1, &
2507 runoff2, &
2508 soilt
2509
2510!-------- 1-d variables
2511 real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: soilice, &
2512 soiliqw
2513
2514!--- Local variables
2515
2516 real (kind_phys) :: infiltrp, transum , &
2517 rainf, prcpms , &
2518 tabs, t3, upflux, xinet
2519 real (kind_phys) :: cp,rovcp,g0,lv,stbolt,xlmelt,dzstop , &
2520 can,epot,fac,fltot,ft,fq,hft , &
2521 q1,ras,sph , &
2522 trans,zn,ci,cvw,tln,tavln,pi , &
2523 dd1,cmc2ms,drycan,wetcan , &
2524 infmax,riw, x
2525 real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, &
2526 thdif,tranf,tav,soilmoism , &
2527 soilicem,soiliqwm,detal , &
2528 fwsat,lwsat,told,smold
2529
2530 real (kind_phys) :: soiltold,smf
2531 real (kind_phys) :: soilres, alfa, fex, fex_fc, fc, psit
2532
2533 INTEGER :: nzs1,nzs2,k
2534
2535!-----------------------------------------------------------------
2536
2537!-- define constants
2538 ci=rhoice*sheatice
2539 xlmelt=con_hfus
2540 cvw=cw
2541
2542 prcpl=prcpms
2543
2544 smf = zero
2545 soiltold = soilt
2546
2547 wetcan= zero
2548 drycan= one
2549
2550!--- Initializing local arrays
2551 DO k=1,nzs
2552 transp(k)=zero
2553 soilmoism(k)=zero
2554 soilice(k)=zero
2555 soiliqw(k)=zero
2556 soilicem(k)=zero
2557 soiliqwm(k)=zero
2558 lwsat(k)=zero
2559 fwsat(k)=zero
2560 tav(k)=zero
2561 cap(k)=zero
2562 thdif(k)=zero
2563 diffu(k)=zero
2564 hydro(k)=zero
2565 tranf(k)=zero
2566 detal(k)=zero
2567 told(k)=zero
2568 smold(k)=zero
2569 ENDDO
2570
2571 nzs1=nzs-1
2572 nzs2=nzs-2
2573 dzstop=one/(zsmain(2)-zsmain(1))
2574 ras=rho*1.e-3_kind_phys ! rho/rhowater
2575 riw=rhoice*1.e-3_kind_phys ! rhoice/rhowater
2576
2577!--- Computation of volumetric content of ice in soil
2578
2579 DO k=1,nzs
2580!- main levels
2581 tln=log(tso(k)/tfrz)
2582 if(tln.lt.zero) then
2583 soiliqw(k)=(dqm+qmin)*(xlmelt* &
2584 (tso(k)-tfrz)/tso(k)/grav/psis) &
2585 **(-one/bclh)-qmin
2586 soiliqw(k)=max(zero,soiliqw(k))
2587 soiliqw(k)=min(soiliqw(k),soilmois(k))
2588 soilice(k)=(soilmois(k)-soiliqw(k))/riw
2589
2590!---- melting and freezing is balanced, soil ice cannot increase
2591 if(keepfr(k).eq.one) then
2592 soilice(k)=min(soilice(k),smfrkeep(k))
2593 soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw)
2594 endif
2595
2596 else
2597 soilice(k)=zero
2598 soiliqw(k)=soilmois(k)
2599 endif
2600
2601 ENDDO
2602
2603 DO k=1,nzs1
2604!- middle of soil layers
2605 tav(k)=0.5_kind_phys*(tso(k)+tso(k+1))
2606 soilmoism(k)=0.5_kind_phys*(soilmois(k)+soilmois(k+1))
2607 tavln=log(tav(k)/tfrz)
2608
2609 if(tavln.lt.zero) then
2610 soiliqwm(k)=(dqm+qmin)*(xlmelt* &
2611 (tav(k)-tfrz)/tav(k)/grav/psis) &
2612 **(-one/bclh)-qmin
2613 fwsat(k)=dqm-soiliqwm(k)
2614 lwsat(k)=soiliqwm(k)+qmin
2615 soiliqwm(k)=max(zero,soiliqwm(k))
2616 soiliqwm(k)=min(soiliqwm(k), soilmoism(k))
2617 soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw
2618!---- melting and freezing is balanced, soil ice cannot increase
2619 if(keepfr(k).eq.one) then
2620 soilicem(k)=min(soilicem(k), &
2621 0.5_kind_phys*(smfrkeep(k)+smfrkeep(k+1)))
2622 soiliqwm(k)=max(zero,soilmoism(k)-soilicem(k)*riw)
2623 fwsat(k)=dqm-soiliqwm(k)
2624 lwsat(k)=soiliqwm(k)+qmin
2625 endif
2626
2627 else
2628 soilicem(k)=zero
2629 soiliqwm(k)=soilmoism(k)
2630 lwsat(k)=dqm+qmin
2631 fwsat(k)=zero
2632 endif
2633
2634 ENDDO
2635
2636 do k=1,nzs
2637 if(soilice(k).gt.zero) then
2638 smfrkeep(k)=soilice(k)
2639 else
2640 smfrkeep(k)=soilmois(k)/riw
2641 endif
2642 enddo
2643
2644!******************************************************************
2645! SOILPROP computes thermal diffusivity, and diffusional and
2646! hydraulic condeuctivities
2647!******************************************************************
2648 CALL soilprop( debug_print, &
2649 xlat, xlon, testptlat, testptlon, &
2650!--- input variables
2651 nzs,fwsat,lwsat,tav,keepfr, &
2652 soilmois,soiliqw,soilice, &
2653 soilmoism,soiliqwm,soilicem, &
2654!--- soil fixed fields
2655 qwrtz,rhocs,dqm,qmin,psis,bclh,ksat, &
2656!--- constants
2657 riw,xlmelt,cp,g0_p,cvw,ci, &
2658 kqwrtz,kice,kwt, &
2659!--- output variables
2660 thdif,diffu,hydro,cap)
2661
2662!********************************************************************
2663!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW
2664
2665 fq=qkms
2666
2667 q1=-qkms*ras*(qvatm - qsg)
2668
2669 dew=zero
2670 IF(qvatm.GE.qsg)THEN
2671 dew=fq*(qvatm-qsg)
2672 ENDIF
2673
2674!--- WETCAN is the fraction of vegetated area covered by canopy
2675!--- water, and DRYCAN is the fraction of vegetated area where
2676!--- transpiration may take place.
2677
2678 wetcan=min(0.25_kind_phys,max(zero,(cst/sat))**cn)
2679 drycan=one-wetcan
2680
2681!**************************************************************
2682! TRANSF computes transpiration function
2683!**************************************************************
2684 CALL transf(debug_print, &
2685 xlat, xlon, testptlat, testptlon, &
2686!--- input variables
2687 nzs,nroot,soiliqw,tabs,lai,gswin, &
2688!--- soil fixed fields
2689 dqm,qmin,ref,wilt,zshalf,pc,iland, &
2690!--- output variables
2691 tranf,transum)
2692
2693!--- Save soil temp and moisture from the beginning of time step
2694 do k=1,nzs
2695 told(k)=tso(k)
2696 smold(k)=soilmois(k)
2697 enddo
2698
2699! Sakaguchi and Zeng (2009) - dry soil resistance to evaporation
2700! if (vgtype==11) then ! MODIS wetland
2701 alfa=one
2702! else
2703 fex=min(one,soilmois(1)/dqm)
2704 fex=max(fex,0.01_kind_phys)
2705 psit=psis*fex ** (-bclh)
2706 psit = max(-1.e5_kind_phys, psit)
2707 alfa=min(one,exp(g0_p*psit/r_v/soilt))
2708 ! print *,'alfa=',alfa, exp(G0_P*psit/r_v/SOILT)
2709! endif
2710 alfa=one
2711! field capacity
2712! 20jun18 - beta in Eq. (5) is called soilres in the code - it limits soil evaporation
2713! when soil moisture is below field capacity. [Lee and Pielke, 1992]
2714! This formulation agrees with observations when top layer is < 2 cm thick.
2715! Soilres = 1 for snow, glaciers and wetland.
2716! fc=ref - suggested in the paper
2717! fc=max(qmin,ref*0.5) ! used prior to 20jun18 change
2718! Switch from ref*0.5 to ref*0.25 will reduce soil resistance, increase direct
2719! evaporation, effects sparsely vegetated areas--> cooler during the day
2720! fc=max(qmin,ref*0.25) !
2721! For now we'll go back to ref*0.5
2722! 3feb21 - in RRFS testing (fv3-based), ref*0.5 gives too much direct
2723! evaporation. Therefore , it is replaced with ref*0.7.
2724 fc=ref
2725 fex_fc=one
2726 if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > zero) then
2727 soilres = one
2728 else
2729 fex_fc=min(one,(soilmois(1)+qmin)/fc)
2730 fex_fc=max(fex_fc,0.01_kind_phys)
2731 soilres=0.25_kind_phys*(one-cos(piconst*fex_fc))**2._kind_phys
2732 endif
2733 IF ( debug_print ) THEN
2734 print *,'piconst=',piconst
2735 print *,'fex,psit,psis,bclh,g0_p,r_v,soilt,alfa,mavail,soilmois(1),fc,ref,soilres,fex_fc', &
2736 fex,psit,psis,bclh,g0_p,r_v,soilt,alfa,mavail,soilmois(1),fc,ref,soilres,fex_fc
2737 endif
2738
2739!**************************************************************
2740! SOILTEMP soilves heat budget and diffusion eqn. in soil
2741!**************************************************************
2742
2743 CALL soiltemp(debug_print,xlat,xlon,testptlat,testptlon,&
2744!--- input variables
2745 i,j,iland,isoil, &
2746 delt,ktau,conflx,nzs,nddzs,nroot, &
2747 prcpms,rainf, &
2748 patm,tabs,qvatm,qcatm,emiss,rnet, &
2749 qkms,tkms,pc,rho,vegfrac, lai, &
2750 thdif,cap,drycan,wetcan, &
2751 transum,dew,mavail,soilres,alfa, &
2752!--- soil fixed fields
2753 dqm,qmin,bclh,zsmain,zshalf,dtdzs,tbq, &
2754!--- constants
2755 xlv,cp,g0_p,cvw,stbolt, &
2756!--- output variables
2757 tso,soilt,qvg,qsg,qcg,x)
2758
2759!************************************************************************
2760
2761!--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW
2762 ett1=zero
2763 dew=zero
2764
2765 IF(qvatm.GE.qsg)THEN
2766 dew=qkms*(qvatm-qsg)
2767 ett1=zero
2768 DO k=1,nzs
2769 transp(k)=zero
2770 ENDDO
2771 ELSE
2772
2773 DO k=1,nroot
2774 transp(k)=vegfrac*ras*qkms* &
2775 (qvatm-qsg)* &
2776 tranf(k)*drycan/zshalf(nroot+1)
2777 IF(transp(k).GT.zero) transp(k)=zero
2778 ett1=ett1-transp(k)
2779 ENDDO
2780 DO k=nroot+1,nzs
2781 transp(k)=zero
2782 enddo
2783 ENDIF
2784
2785!-- Recalculate volumetric content of frozen water in soil
2786 DO k=1,nzs
2787!- main levels
2788 tln=log(tso(k)/tfrz)
2789 if(tln.lt.zero) then
2790 soiliqw(k)=(dqm+qmin)*(xlmelt* &
2791 (tso(k)-tfrz)/tso(k)/grav/psis) &
2792 **(-one/bclh)-qmin
2793 soiliqw(k)=max(zero,soiliqw(k))
2794 soiliqw(k)=min(soiliqw(k),soilmois(k))
2795 soilice(k)=(soilmois(k)-soiliqw(k))/riw
2796!---- melting and freezing is balanced, soil ice cannot increase
2797 if(keepfr(k).eq.one) then
2798 soilice(k)=min(soilice(k),smfrkeep(k))
2799 soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw)
2800 endif
2801
2802 else
2803 soilice(k)=zero
2804 soiliqw(k)=soilmois(k)
2805 endif
2806 ENDDO
2807
2808!*************************************************************************
2809! SOILMOIST solves moisture budget (Smirnova et al., 1996, EQ.22,28)
2810! and Richards eqn.
2811!*************************************************************************
2812 CALL soilmoist (debug_print, &
2813 xlat, xlon, testptlat, testptlon, &
2814!-- input
2815 delt,nzs,nddzs,dtdzs,dtdzs2,riw, &
2816 zsmain,zshalf,diffu,hydro, &
2817 qsg,qvg,qcg,qcatm,qvatm,-infwater, &
2818 qkms,transp,drip,dew,zero,soilice,vegfrac, &
2819 zero,soilres, &
2820!-- soil properties
2821 dqm,qmin,ref,ksat,ras,infmax, &
2822!-- output
2823 soilmois,soiliqw,mavail,runoff1, &
2824 runoff2,infiltrp)
2825
2826!--- KEEPFR is 1 when the temperature and moisture in soil
2827!--- are both increasing. In this case soil ice should not
2828!--- be increasing according to the freezing curve.
2829!--- Some part of ice is melted, but additional water is
2830!--- getting frozen. Thus, only structure of frozen soil is
2831!--- changed, and phase changes are not affecting the heat
2832!--- transfer. This situation may happen when it rains on the
2833!--- frozen soil.
2834
2835 do k=1,nzs
2836 if (soilice(k).gt.zero) then
2837 if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then
2838 keepfr(k)=one
2839 else
2840 keepfr(k)=zero
2841 endif
2842 endif
2843 enddo
2844
2845!--- THE DIAGNOSTICS OF SURFACE FLUXES
2846
2847 t3 = stbolt*soiltold*soiltold*soiltold
2848 upflux = t3 * 0.5_kind_phys*(soiltold+soilt)
2849 xinet = emiss*(glw-upflux)
2850 hft=-tkms*cp*rho*(tabs-soilt)
2851 hfx=-tkms*cp*rho*(tabs-soilt) &
2852 *(p1000mb*0.00001_kind_phys/patm)**rovcp
2853 q1=-qkms*ras*(qvatm - qsg)
2854
2855 cmc2ms = zero
2856 IF (q1.LE.zero) THEN
2857! --- condensation
2858 ec1= zero
2859 edir1= zero
2860 ett1= zero
2861 if(myj) then
2862!-- moisture flux for coupling with MYJ PBL
2863 eeta=-qkms*ras*(qvatm/(one+qvatm) - qsg/(one+qsg))*rhowater
2864 cst= cst-eeta*delt*vegfrac
2865 IF (debug_print ) THEN
2866!!! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then
2867 print *,'Cond MYJ EETA',eeta,eeta*xlv, i,j
2868 ENDIF
2869 else ! myj
2870!-- actual moisture flux from RUC LSM
2871 eeta= - rho*dew
2872 cst=cst+delt*dew*ras * vegfrac
2873 IF (debug_print ) THEN
2874! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then
2875 print *,'Cond RUC LSM EETA',eeta,eeta*xlv, i,j
2876 ENDIF
2877 endif ! myj
2878 qfx= xlv*eeta
2879 eeta= - rho*dew
2880 ELSE
2881! --- evaporation
2882 edir1 =-soilres*(one-vegfrac)*qkms*ras* &
2883 (qvatm-qvg)
2884 cmc2ms=cst/delt*ras
2885 ec1 = q1 * wetcan * vegfrac
2886 IF (debug_print ) THEN
2887 IF(i.eq.440.and.j.eq.180.or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then
2888 print *,'CST before update=',cst
2889 print *,'EC1=',ec1,'CMC2MS=',cmc2ms
2890 ENDIF
2891 ENDIF
2892
2893 cst=max(zero,cst-ec1 * delt)
2894
2895 if (myj) then
2896!-- moisture flux for coupling with MYJ PBL
2897 eeta=-soilres*qkms*ras*(qvatm/(one+qvatm) - qvg/(one+qvg))*rhowater
2898 else ! myj
2899 IF (debug_print ) THEN
2900! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then
2901 print *,'QKMS,RAS,QVATM/(one+QVATM),QVG/(one+QVG),QSG ', &
2902 qkms,ras,qvatm/(one+qvatm),qvg/(one+qvg),qsg
2903 print *,'Q1*(1.-vegfrac),EDIR1',q1*(one-vegfrac),edir1
2904 print *,'CST,WETCAN,DRYCAN',cst,wetcan,drycan
2905 print *,'EC1=',ec1,'ETT1=',ett1,'CMC2MS=',cmc2ms,'CMC2MS*ras=',cmc2ms*ras
2906 ENDIF
2907!-- actual moisture flux from RUC LSM
2908 eeta = (edir1 + ec1 + ett1)*rhowater
2909 IF (debug_print ) THEN
2910! IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then
2911 print *,'RUC LSM EETA',eeta,eeta*xlv
2912 ENDIF
2913 endif ! myj
2914 qfx= xlv * eeta
2915 eeta = (edir1 + ec1 + ett1)*rhowater
2916 ENDIF
2917 IF (debug_print ) THEN
2918 print *,'potential temp HFT ',hft
2919 print *,'abs temp HFX ',hfx
2920 ENDIF
2921
2922 evapl=eeta
2923 s=thdif(1)*cap(1)*dzstop*(tso(1)-tso(2))
2924! Energy budget
2925 fltot=rnet-hft-xlv*eeta-s-x
2926 IF (debug_print ) THEN
2927! IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then
2928 print *,'SOIL - FLTOT,RNET,HFT,QFX,S,X=',i,j,fltot,rnet,hft,xlv*eeta,s,x
2929 print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac',&
2930 edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac
2931 ENDIF
2932 if(detal(1) .ne. zero) then
2933! SMF - energy of phase change in the first soil layer
2934 smf=fltot
2935 IF (debug_print ) THEN
2936 print *,'detal(1),xlmelt,soiliqwm(1),delt',detal(1),xlmelt,soiliqwm(1),delt
2937 print *,'Implicit phase change in the first layer - smf=',smf
2938 ENDIF
2939 endif
2940
2941
2942 222 CONTINUE
2943
2944 1123 FORMAT(i5,8f12.3)
2945 1133 FORMAT(i7,8e12.4)
2946 123 format(i6,f6.2,7f8.1)
2947 122 FORMAT(1x,2i3,6f8.1,f8.3,f8.2)
2948!-------------------------------------------------------------------
2949 END SUBROUTINE soil
2950!-------------------------------------------------------------------
2951
2957 SUBROUTINE sice ( debug_print,xlat,xlon, &
2958 i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables
2959 PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW, &
2960 EMISS,RNET,QKMS,TKMS,rho,myj, &
2961 tice,rhosice,capice,thdifice, & !--- sea ice parameters
2962 zsmain,zshalf,DTDZS,DTDZS2,tbq, &
2963 xlv,CP,rovcp,cw,stbolt,tabs, & !--- constants
2964 tso,dew,soilt,qvg,qsg,qcg, & !--- output variables
2965 eeta,qfx,hfx,s,evapl,prcpl,fltot &
2966 )
2967
2968!*****************************************************************
2969! Energy budget and heat diffusion eqns. for
2970! sea ice
2971!*************************************************************
2972
2973 IMPLICIT NONE
2974!-----------------------------------------------------------------
2975
2976!--- input variables
2977
2978 INTEGER, INTENT(IN ) :: nroot,ktau,nzs , &
2979 nddzs !nddzs=2*(nzs-2)
2980 INTEGER, INTENT(IN ) :: i,j,iland,isoil
2981 real (kind_phys), INTENT(IN ) :: delt,conflx,xlat,xlon
2982 LOGICAL, INTENT(IN ) :: myj, debug_print
2983!--- 3-D Atmospheric variables
2984 real (kind_phys), &
2985 INTENT(IN ) :: patm, &
2986 qvatm, &
2987 qcatm
2988!--- 2-D variables
2989 real (kind_phys), &
2990 INTENT(IN ) :: glw, &
2991 gsw, &
2992 emiss, &
2993 rho, &
2994 qkms, &
2995 tkms
2996!--- sea ice properties
2997 real (kind_phys), DIMENSION(1:NZS) , &
2998 INTENT(IN ) :: &
2999 tice, &
3000 rhosice, &
3001 capice, &
3002 thdifice
3003
3004
3005 real (kind_phys), INTENT(IN ) :: &
3006 cw, &
3007 xlv
3008
3009
3010 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: zsmain, &
3011 zshalf, &
3012 dtdzs2
3013
3014 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: dtdzs
3015
3016 real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: tbq
3017
3018
3019!--- input/output variables
3020!----soil temperature
3021 real (kind_phys), DIMENSION( 1:nzs ), INTENT(INOUT) :: tso
3022!-------- 2-d variables
3023 real (kind_phys), &
3024 INTENT(INOUT) :: dew, &
3025 eeta, &
3026 evapl, &
3027 prcpl, &
3028 qvg, &
3029 qsg, &
3030 qcg, &
3031 rnet, &
3032 qfx, &
3033 hfx, &
3034 s, &
3035 soilt
3036
3037!--- Local variables
3038 real (kind_phys) :: x,x1,x2,x4,tn,denom
3039 real (kind_phys) :: rainf, prcpms , &
3040 tabs, t3, upflux, xinet
3041
3042 real (kind_phys) :: cp,rovcp,g0,lv,stbolt,xlmelt,dzstop , &
3043 epot,fltot,ft,fq,hft,ras,cvw
3044
3045 real (kind_phys) :: fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11, &
3046 pi,h,fkq,r210,aa,bb,pp,q1,qs1,ts1,tq2,tx2 , &
3047 tdenom,qgold,snoh
3048
3049 real (kind_phys) :: aa1,rhcs, icemelt
3050
3051
3052 real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso
3053
3054 INTEGER :: nzs1,nzs2,k,k1,kn,kk
3055
3056!-----------------------------------------------------------------
3057
3058!-- define constants
3059 xlmelt=con_hfus
3060 cvw=cw
3061
3062 prcpl=prcpms
3063
3064 nzs1=nzs-1
3065 nzs2=nzs-2
3066 dzstop=1./(zsmain(2)-zsmain(1))
3067 ras=rho*1.e-3_kind_phys
3068
3069 do k=1,nzs
3070 cotso(k)=zero
3071 rhtso(k)=zero
3072 enddo
3073
3074 cotso(1)=zero
3075 rhtso(1)=tso(nzs)
3076
3077 DO 33 k=1,nzs2
3078 kn=nzs-k
3079 k1=2*kn-3
3080 x1=dtdzs(k1)*thdifice(kn-1)
3081 x2=dtdzs(k1+1)*thdifice(kn)
3082 ft=tso(kn)+x1*(tso(kn-1)-tso(kn)) &
3083 -x2*(tso(kn)-tso(kn+1))
3084 denom=1.+x1+x2-x2*cotso(k)
3085 cotso(k+1)=x1/denom
3086 rhtso(k+1)=(ft+x2*rhtso(k))/denom
3087 33 CONTINUE
3088
3089!************************************************************************
3090!--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26)
3091 rhcs=capice(1)
3092 h=one
3093 fkt=tkms
3094 d1=cotso(nzs1)
3095 d2=rhtso(nzs1)
3096 tn=tso(1)
3097 d9=thdifice(1)*rhcs*dzstop
3098 d10=tkms*cp*rho
3099 r211=.5_kind_phys*conflx/delt
3100 r21=r211*cp*rho
3101 r22=.5_kind_phys/(thdifice(1)*delt*dzstop**2)
3102 r6=emiss *stbolt*.5_kind_phys*tn**4
3103 r7=r6/tn
3104 d11=rnet+r6
3105 tdenom=d9*(one-d1+r22)+d10+r21+r7 &
3106 +rainf*cvw*prcpms
3107 fkq=qkms*rho
3108 r210=r211*rho
3109 aa=xls*(fkq+r210)/tdenom
3110 bb=(d10*tabs+r21*tn+xls*(qvatm*fkq &
3111 +r210*qvg)+d11+d9*(d2+r22*tn) &
3112 +rainf*cvw*prcpms*max(tfrz,tabs) &
3113 )/tdenom
3114 aa1=aa
3115 pp=patm*rhowater
3116 aa1=aa1/pp
3117 IF (debug_print ) THEN
3118 print *,' VILKA-SEAICE1'
3119 print *,'D10,TABS,R21,TN,QVATM,FKQ', &
3120 d10,tabs,r21,tn,qvatm,fkq
3121 print *,'RNET, EMISS, STBOLT, SOILT',rnet, emiss, stbolt, soilt
3122 print *,'R210,QVG,D11,D9,D2,R22,RAINF,CVW,PRCPMS,TDENOM', &
3123 r210,qvg,d11,d9,d2,r22,rainf,cvw,prcpms,tdenom
3124 print *,'tn,aa1,bb,pp,fkq,r210', &
3125 tn,aa1,bb,pp,fkq,r210
3126 ENDIF
3127 qgold=qsg
3128 CALL vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil,xlat,xlon)
3129!--- it is saturation over sea ice
3130 qvg=qs1
3131 qsg=qs1
3132 tso(1)=min(con_tice,ts1)
3133 qcg=zero
3134!--- sea ice melting is not included in this simple approach
3135!--- SOILT - skin temperature
3136 soilt=tso(1)
3137!---- Final solution for soil temperature - TSO
3138 DO k=2,nzs
3139 kk=nzs-k+1
3140 tso(k)=min(con_tice,rhtso(kk)+cotso(kk)*tso(k-1))
3141 END DO
3142!--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW
3143 dew=zero
3144
3145!--- THE DIAGNOSTICS OF SURFACE FLUXES
3146 t3 = stbolt*tn*tn*tn
3147 upflux = t3 *0.5_kind_phys*(tn+soilt)
3148 xinet = emiss*(glw-upflux)
3149 hft=-tkms*cp*rho*(tabs-soilt)
3150 hfx=-tkms*cp*rho*(tabs-soilt) &
3151 *(p1000mb*0.00001_kind_phys/patm)**rovcp
3152 q1=-qkms*ras*(qvatm - qsg)
3153 IF (q1.LE.zero) THEN
3154! --- condensation
3155 if(myj) then
3156!-- moisture flux for coupling with MYJ PBL
3157 eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*rhowater
3158 IF (debug_print ) THEN
3159 print *,'MYJ EETA',eeta
3160 ENDIF
3161 else ! myj
3162!-- actual moisture flux from RUC LSM
3163 dew=qkms*(qvatm-qsg)
3164 eeta= - rho*dew
3165 IF (debug_print ) THEN
3166 print *,'RUC LSM EETA',eeta
3167 ENDIF
3168 endif ! myj
3169 qfx= xls*eeta
3170 eeta= - rho*dew
3171 ELSE
3172! --- evaporation
3173 if(myj) then
3174!-- moisture flux for coupling with MYJ PBL
3175 eeta=-qkms*ras*(qvatm/(1.+qvatm) - qvg/(1.+qvg))*rhowater
3176 IF (debug_print ) THEN
3177 print *,'MYJ EETA',eeta
3178 ENDIF
3179 else ! myj
3180! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
3181!-- actual moisture flux from RUC LSM
3182 eeta = q1*rhowater
3183 IF (debug_print ) THEN
3184 print *,'RUC LSM EETA',eeta
3185 ENDIF
3186 endif ! myj
3187 qfx= xls * eeta
3188 eeta = q1*rhowater
3189 ENDIF
3190 evapl=eeta
3191
3192 s=thdifice(1)*capice(1)*dzstop*(tso(1)-tso(2))
3193! heat storage in surface layer
3194 snoh=zero
3195! There is ice melt
3196 x= (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(soilt-tn) + &
3197 xls*rho*r211*(qsg-qgold)
3198 x=x &
3199! "heat" from rain
3200 -rainf*cvw*prcpms*(max(tfrz,tabs)-soilt)
3201
3202!-- excess energy spent on sea ice melt
3203 icemelt=rnet-xls*eeta -hft -s -x
3204 IF (debug_print ) THEN
3205 print *,'icemelt=',icemelt
3206 ENDIF
3207
3208 fltot=rnet-xls*eeta-hft-s-x-icemelt
3209 IF (debug_print ) THEN
3210 print *,'SICE - FLTOT,RNET,HFT,QFX,S,icemelt,X=', &
3211 fltot,rnet,hft,xls*eeta,s,icemelt,x
3212 ENDIF
3213
3214!-------------------------------------------------------------------
3215 END SUBROUTINE sice
3216!-------------------------------------------------------------------
3217
3223 SUBROUTINE snowsoil ( debug_print,xlat,xlon, &
3224 testptlat,testptlon, &
3225 i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & !--- input variables
3226 isncond_opt,isncovr_opt, &
3227 meltfactor,rhonewsn,SNHEI_CRIT, & ! new
3228 ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, &
3229 RHOSN, &
3230 PATM,QVATM,QCATM, &
3231 GLW,GSW,GSWin,EMISS,RNET,IVGTYP, &
3232 QKMS,TKMS,PC,cst,drip,infwater, &
3233 rho,vegfrac,alb,znt,lai, &
3234 MYJ, & !--- soil fixed fields
3235 QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, &
3236 sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, &
3237 xlv,CP,rovcp,G0_P,cw,stbolt,TABS, & !--- constants
3238 KQWRTZ,KICE,KWT, &
3239 ilnb,snweprint,snheiprint,rsm, & !--- output variables
3240 soilmois,tso,smfrkeep,keepfr, &
3241 dew,soilt,soilt1,tsnav, &
3242 qvg,qsg,qcg,SMELT,SNOH,SNFLX,SNOM, &
3243 edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, &
3244 prcpl,fltot,runoff1,runoff2,mavail,soilice, &
3245 soiliqw,infiltrp )
3246
3247!***************************************************************
3248! Energy and moisture budget for snow, heat diffusion eqns.
3249! in snow and soil, Richards eqn. for soil covered with snow
3250!
3251! DELT - time step (s)
3252! ktau - numver of time step
3253! CONFLX - depth of constant flux layer (m)
3254! J,I - the location of grid point
3255! IME, JME, NZS - dimensions of the domain
3256! NROOT - number of levels within the root zone
3257! PRCPMS - precipitation rate in m/s
3258! NEWSNOW - pcpn in soilid form (m)
3259! SNHEI, SNWE - snow height and snow water equivalent (m)
3260! RHOSN - snow density (kg/m-3)
3261! PATM - pressure (bar)
3262! QVATM,QCATM - cloud and water vapor mixing ratio
3263! at the first atm. level (kg/kg)
3264! GLW, GSW - incoming longwave and absorbed shortwave
3265! radiation at the surface (W/m^2)
3266! EMISS,RNET - emissivity (0-1) of the ground surface and net
3267! radiation at the surface (W/m^2)
3268! QKMS - exchange coefficient for water vapor in the
3269! surface layer (m/s)
3270! TKMS - exchange coefficient for heat in the surface
3271! layer (m/s)
3272! PC - plant coefficient (resistance) (0-1)
3273! RHO - density of atmosphere near surface (kg/m^3)
3274! VEGFRAC - greeness fraction (0-1)
3275! RHOCS - volumetric heat capacity of dry soil (J/m^3/K)
3276! DQM, QMIN - porosity minus residual soil moisture QMIN (m^3/m^3)
3277! REF, WILT - field capacity soil moisture and the
3278! wilting point (m^3/m^3)
3279! PSIS - matrix potential at saturation (m)
3280! BCLH - exponent for Clapp-Hornberger parameterization
3281! KSAT - saturated hydraulic conductivity (m/s)
3282! SAT - maximum value of water intercepted by canopy (m)
3283! CN - exponent for calculation of canopy water
3284! ZSMAIN - main levels in soil (m)
3285! ZSHALF - middle of the soil layers (m)
3286! DTDZS,DTDZS2 - dt/(2.*dzshalf*dzmain) and dt/dzshalf in soil
3287! TBQ - table to define saturated mixing ration
3288! of water vapor for given temperature and pressure
3289! ilnb - number of layers in snow
3290! rsm - liquid water inside snow pack (m)
3291! SOILMOIS,TSO - soil moisture (m^3/m^3) and temperature (K)
3292! DEW - dew in (kg/m^2 s)
3293! SOILT - skin temperature (K)
3294! SOILT1 - snow temperature at 7.5 cm depth (K)
3295! TSNAV - average temperature of snow pack (C)
3296! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of
3297! water vapor and cloud at the ground
3298! surface, respectively (kg/kg)
3299! EDIR1, EC1, ETT1, EETA - direct evaporation, evaporation of
3300! canopy water, transpiration (kg m-2 s-1) and total
3301! evaporation in (m s-1).
3302! QFX, HFX - latent and sensible heat fluxes (W/m^2)
3303! S - soil heat flux in the top layer (W/m^2)
3304! SUBLIM - snow sublimation (kg/m^2/s)
3305! RUNOFF1 - surface runoff (m/s)
3306! RUNOFF2 - underground runoff (m)
3307! MAVAIL - moisture availability in the top soil layer (0-1)
3308! SOILICE - content of soil ice in soil layers (m^3/m^3)
3309! SOILIQW - lliquid water in soil layers (m^3/m^3)
3310! INFILTRP - infiltration flux from the top of soil domain (m/s)
3311! XINET - net long-wave radiation (W/m^2)
3312!
3313!*******************************************************************
3314
3315 IMPLICIT NONE
3316!-------------------------------------------------------------------
3317!--- input variables
3318 LOGICAL, INTENT(IN ) :: debug_print
3319 INTEGER, INTENT(IN ) :: nroot,ktau,nzs , &
3320 nddzs !nddzs=2*(nzs-2)
3321 INTEGER, INTENT(IN ) :: i,j,isoil,isncond_opt,isncovr_opt
3322
3323 real (kind_phys), INTENT(IN ) :: delt,conflx,prcpms, &
3324 rainf,newsnow,rhonewsn, &
3325 testptlat,testptlon, &
3326 snhei_crit,meltfactor,xlat,xlon
3327
3328 LOGICAL, INTENT(IN ) :: myj
3329
3330!--- 3-D Atmospheric variables
3331 real (kind_phys), &
3332 INTENT(IN ) :: patm, &
3333 qvatm, &
3334 qcatm
3335!--- 2-D variables
3336 real (kind_phys) , &
3337 INTENT(IN ) :: glw, &
3338 gsw, &
3339 gswin, &
3340 rho, &
3341 pc, &
3342 vegfrac, &
3343 lai, &
3344 infwater, &
3345 qkms, &
3346 tkms
3347
3348 INTEGER, INTENT(IN ) :: ivgtyp
3349!--- soil properties
3350 real (kind_phys) , &
3351 INTENT(IN ) :: rhocs, &
3352 bclh, &
3353 dqm, &
3354 ksat, &
3355 psis, &
3356 qmin, &
3357 qwrtz, &
3358 ref, &
3359 sat, &
3360 wilt
3361
3362 real (kind_phys), INTENT(IN ) :: cn, &
3363 cw, &
3364 xlv, &
3365 g0_p, &
3366 kqwrtz, &
3367 kice, &
3368 kwt
3369
3370
3371 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: zsmain, &
3372 zshalf, &
3373 dtdzs2
3374
3375 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: dtdzs
3376
3377 real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: tbq
3378
3379
3380!--- input/output variables
3381!-------- 3-d soil moisture and temperature
3382 real (kind_phys), DIMENSION( 1:nzs ) , &
3383 INTENT(INOUT) :: tso, &
3384 soilmois, &
3385 smfrkeep
3386
3387 real (kind_phys), DIMENSION( 1:nzs ) , &
3388 INTENT(INOUT) :: keepfr
3389
3390
3391 INTEGER, INTENT(INOUT) :: iland
3392
3393
3394!-------- 2-d variables
3395 real (kind_phys) , &
3396 INTENT(INOUT) :: dew, &
3397 cst, &
3398 drip, &
3399 edir1, &
3400 ec1, &
3401 ett1, &
3402 eeta, &
3403 rhosn, &
3404 sublim, &
3405 prcpl, &
3406 alb, &
3407 emiss, &
3408 znt, &
3409 mavail, &
3410 qvg, &
3411 qsg, &
3412 qcg, &
3413 qfx, &
3414 hfx, &
3415 s, &
3416 runoff1, &
3417 runoff2, &
3418 snwe, &
3419 snhei, &
3420 smelt, &
3421 snom, &
3422 snoh, &
3423 snflx, &
3424 soilt, &
3425 soilt1, &
3426 snowfrac, &
3427 tsnav
3428
3429 INTEGER, INTENT(INOUT) :: ilnb
3430
3431!-------- 1-d variables
3432 real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: soilice, &
3433 soiliqw
3434
3435 real (kind_phys), INTENT(OUT) :: rsm, &
3436 snweprint, &
3437 snheiprint
3438!--- Local variables
3439
3440
3441 INTEGER :: nzs1,nzs2,k
3442
3443 real (kind_phys) :: infiltrp, transum , &
3444 snth, newsn , &
3445 tabs, t3, upflux, xinet , &
3446 beta, snwepr,epdt,pp
3447 real (kind_phys) :: cp,rovcp,g0,lv,xlvm,stbolt,xlmelt,dzstop, &
3448 can,epot,fac,fltot,ft,fq,hft , &
3449 q1,ras,sph , &
3450 trans,zn,ci,cvw,tln,tavln,pi , &
3451 dd1,cmc2ms,drycan,wetcan , &
3452 infmax,riw,deltsn,h,umveg
3453
3454 real (kind_phys), DIMENSION(1:NZS) :: transp,cap,diffu,hydro, &
3455 thdif,tranf,tav,soilmoism , &
3456 soilicem,soiliqwm,detal , &
3457 fwsat,lwsat,told,smold
3458 real (kind_phys) :: soiltold, qgold
3459
3460 real (kind_phys) :: rnet, x
3461
3462!-----------------------------------------------------------------
3463
3464 cvw=cw
3465 xlmelt=con_hfus
3466!-- heat of water vapor sublimation
3467 xlvm=xlv+xlmelt
3468
3469!--- SNOW flag -- ISICE
3470!--- DELTSN - is the threshold for splitting the snow layer into 2 layers.
3471!--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm,
3472!--- equivalent to 0.03 m SNWE. For other snow densities the threshold is
3473!--- computed using SNWE=0.03 m and current snow density.
3474!--- SNTH - the threshold below which the snow layer is combined with
3475!--- the top soil layer. SNTH is computed using snwe=0.016 m, and
3476!--- equals 4 cm for snow density 400 kg/m^3.
3477
3478!save SOILT and QVG
3479 soiltold=soilt
3480 qgold=qvg
3481
3482 x=zero
3483
3484! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE
3485 deltsn=0.05_kind_phys*rhowater/rhosn
3486 snth=0.01_kind_phys*rhowater/rhosn
3487
3488! For 2-layer snow model when the snow depth is marginally higher than DELTSN,
3489! reset DELTSN to half of snow depth.
3490 IF(snhei.GE.deltsn+snth) THEN
3491 if(snhei-deltsn-snth.lt.snth) deltsn=0.5_kind_phys*(snhei-snth)
3492 IF (debug_print ) THEN
3493 print *,'DELTSN is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth
3494 ENDIF
3495 ENDIF
3496
3497 ci=rhoice*sheatice
3498 ras=rho*1.e-3_kind_dbl_prec ! rho/rhowater
3499 riw=rhoice*1.e-3_kind_dbl_prec ! rhoice/rhowater
3500 rsm=zero
3501
3502 DO k=1,nzs
3503 transp(k)=zero
3504 soilmoism(k)=zero
3505 soiliqwm(k)=zero
3506 soilice(k)=zero
3507 soilicem(k)=zero
3508 lwsat(k)=zero
3509 fwsat(k)=zero
3510 tav(k)=zero
3511 cap(k)=zero
3512 diffu(k)=zero
3513 hydro(k)=zero
3514 thdif(k)=zero
3515 tranf(k)=zero
3516 detal(k)=zero
3517 told(k)=zero
3518 smold(k)=zero
3519 ENDDO
3520
3521 snweprint=zero
3522 snheiprint=zero
3523 prcpl=prcpms
3524
3525!*** DELTSN is the depth of the top layer of snow where
3526!*** there is a temperature gradient, the rest of the snow layer
3527!*** is considered to have constant temperature
3528
3529
3530 nzs1=nzs-1
3531 nzs2=nzs-2
3532 dzstop=one/(zsmain(2)-zsmain(1))
3533
3534!----- THE CALCULATION OF THERMAL DIFFUSIVITY, DIFFUSIONAL AND ---
3535!----- HYDRAULIC CONDUCTIVITY (SMIRNOVA ET AL. 1996, EQ.2,5,6) ---
3536!tgs - the following loop is added to define the amount of frozen
3537!tgs - water in soil if there is any
3538 DO k=1,nzs
3539
3540 tln=log(tso(k)/tfrz)
3541 if(tln.lt.zero) then
3542 soiliqw(k)=(dqm+qmin)*(xlmelt* &
3543 (tso(k)-tfrz)/tso(k)/grav/psis) &
3544 **(-one/bclh)-qmin
3545 soiliqw(k)=max(zero,soiliqw(k))
3546 soiliqw(k)=min(soiliqw(k),soilmois(k))
3547 soilice(k)=(soilmois(k)-soiliqw(k))/riw
3548
3549!---- melting and freezing is balanced, soil ice cannot increase
3550 if(keepfr(k).eq.1.) then
3551 soilice(k)=min(soilice(k),smfrkeep(k))
3552 soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw)
3553 endif
3554
3555 else
3556 soilice(k)=zero
3557 soiliqw(k)=soilmois(k)
3558 endif
3559
3560 ENDDO
3561
3562 DO k=1,nzs1
3563
3564 tav(k)=0.5_kind_phys*(tso(k)+tso(k+1))
3565 soilmoism(k)=0.5_kind_phys*(soilmois(k)+soilmois(k+1))
3566 tavln=log(tav(k)/tfrz)
3567
3568 if(tavln.lt.zero) then
3569 soiliqwm(k)=(dqm+qmin)*(xlmelt* &
3570 (tav(k)-tfrz)/tav(k)/grav/psis) &
3571 **(-one/bclh)-qmin
3572 fwsat(k)=dqm-soiliqwm(k)
3573 lwsat(k)=soiliqwm(k)+qmin
3574 soiliqwm(k)=max(zero,soiliqwm(k))
3575 soiliqwm(k)=min(soiliqwm(k), soilmoism(k))
3576 soilicem(k)=(soilmoism(k)-soiliqwm(k))/riw
3577!---- melting and freezing is balanced, soil ice cannot increase
3578 if(keepfr(k).eq.one) then
3579 soilicem(k)=min(soilicem(k), &
3580 0.5_kind_phys*(smfrkeep(k)+smfrkeep(k+1)))
3581 soiliqwm(k)=max(zero,soilmoism(k)-soilicem(k)*riw)
3582 fwsat(k)=dqm-soiliqwm(k)
3583 lwsat(k)=soiliqwm(k)+qmin
3584 endif
3585
3586 else
3587 soilicem(k)=zero
3588 soiliqwm(k)=soilmoism(k)
3589 lwsat(k)=dqm+qmin
3590 fwsat(k)=zero
3591
3592 endif
3593 ENDDO
3594
3595 do k=1,nzs
3596 if(soilice(k).gt.zero) then
3597 smfrkeep(k)=soilice(k)
3598 else
3599 smfrkeep(k)=soilmois(k)/riw
3600 endif
3601 enddo
3602
3603!******************************************************************
3604! SOILPROP computes thermal diffusivity, and diffusional and
3605! hydraulic condeuctivities
3606!******************************************************************
3607 CALL soilprop(debug_print, &
3608 xlat, xlon, testptlat, testptlon, &
3609!--- input variables
3610 nzs,fwsat,lwsat,tav,keepfr, &
3611 soilmois,soiliqw,soilice, &
3612 soilmoism,soiliqwm,soilicem, &
3613!--- soil fixed fields
3614 qwrtz,rhocs,dqm,qmin,psis,bclh,ksat, &
3615!--- constants
3616 riw,xlmelt,cp,g0_p,cvw,ci, &
3617 kqwrtz,kice,kwt, &
3618!--- output variables
3619 thdif,diffu,hydro,cap)
3620
3621!********************************************************************
3622!--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW
3623
3624 smelt=zero
3625 h=mavail ! =1. if snowfrac=1
3626
3627 fq=qkms
3628
3629
3630!--- If vegfrac.ne.0. then part of falling snow can be
3631!--- intercepted by the canopy.
3632
3633 dew=zero
3634 umveg=one-vegfrac
3635 epot = -fq*(qvatm-qsg)
3636
3637 IF (debug_print ) THEN
3638 print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst
3639 ENDIF
3640
3641!-- Save SNWE from the previous time step
3642 snwepr=snwe
3643
3644! check if all snow can evaporate during DT
3645 beta=one
3646 epdt = epot * ras *delt
3647 IF(epdt > zero .and. snwepr.LE.epdt) THEN
3648 beta=snwepr/epdt
3649 snwe=zero
3650 ENDIF
3651
3652 wetcan=min(0.25_kind_phys,max(zero,(cst/sat))**cn)
3653 drycan=one-wetcan
3654
3655!**************************************************************
3656! TRANSF computes transpiration function
3657!**************************************************************
3658 CALL transf(debug_print, &
3659 xlat, xlon, testptlat, testptlon, &
3660!--- input variables
3661 nzs,nroot,soiliqw,tabs,lai,gswin, &
3662!--- soil fixed fields
3663 dqm,qmin,ref,wilt,zshalf,pc,iland, &
3664!--- output variables
3665 tranf,transum)
3666
3667!--- Save soil temp and moisture from the beginning of time step
3668 do k=1,nzs
3669 told(k)=tso(k)
3670 smold(k)=soilmois(k)
3671 enddo
3672
3673!**************************************************************
3674! SNOWTEMP solves heat budget and diffusion eqn. in soil
3675!**************************************************************
3676
3677 IF (debug_print ) THEN
3678print *, 'TSO before calling SNOWTEMP: ', tso
3679 ENDIF
3680 CALL snowtemp(debug_print,xlat,xlon,testptlat,testptlon,&
3681!--- input variables
3682 i,j,iland,isoil, &
3683 delt,ktau,conflx,nzs,nddzs,nroot, &
3684 isncond_opt,isncovr_opt, &
3685 snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, &
3686 beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor
3687 prcpms,rainf, &
3688 patm,tabs,qvatm,qcatm, &
3689 glw,gsw,emiss,rnet, &
3690 qkms,tkms,pc,rho,vegfrac, &
3691 thdif,cap,drycan,wetcan,cst, &
3692 tranf,transum,dew,mavail, &
3693!--- soil fixed fields
3694 dqm,qmin,psis,bclh, &
3695 zsmain,zshalf,dtdzs,tbq, &
3696!--- constants
3697 xlvm,cp,rovcp,g0_p,cvw,stbolt, &
3698!--- output variables
3699 snweprint,snheiprint,rsm, &
3700 tso,soilt,soilt1,tsnav,qvg,qsg,qcg, &
3701 smelt,snoh,snflx,s,ilnb,x)
3702
3703!************************************************************************
3704!--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW
3705 dew=zero
3706 ett1=zero
3707 pp=patm*rhowater
3708 epot = -fq*(qvatm-qsg)
3709 IF(epot.GT.zero) THEN
3710! Evaporation
3711 DO k=1,nroot
3712 transp(k)=vegfrac*ras*fq*(qvatm-qsg) &
3713 *tranf(k)*drycan/zshalf(nroot+1)
3714 ett1=ett1-transp(k)
3715 ENDDO
3716 DO k=nroot+1,nzs
3717 transp(k)=zero
3718 enddo
3719
3720 ELSE
3721! Sublimation
3722 dew=-epot
3723 DO k=1,nzs
3724 transp(k)=zero
3725 ENDDO
3726 ett1=zero
3727 ENDIF
3728
3729!-- recalculating of frozen water in soil
3730 DO k=1,nzs
3731 tln=log(tso(k)/tfrz)
3732 if(tln.lt.zero) then
3733 soiliqw(k)=(dqm+qmin)*(xlmelt* &
3734 (tso(k)-tfrz)/tso(k)/grav/psis) &
3735 **(-one/bclh)-qmin
3736 soiliqw(k)=max(zero,soiliqw(k))
3737 soiliqw(k)=min(soiliqw(k),soilmois(k))
3738 soilice(k)=(soilmois(k)-soiliqw(k))/riw
3739!---- melting and freezing is balanced, soil ice cannot increase
3740 if(keepfr(k).eq.one) then
3741 soilice(k)=min(soilice(k),smfrkeep(k))
3742 soiliqw(k)=max(zero,soilmois(k)-soilice(k)*riw)
3743 endif
3744
3745 else
3746 soilice(k)=zero
3747 soiliqw(k)=soilmois(k)
3748 endif
3749 ENDDO
3750
3751!*************************************************************************
3752!--- TQCAN FOR SOLUTION OF MOISTURE BALANCE (Smirnova et al. 1996, EQ.22,28)
3753! AND TSO,ETA PROFILES
3754!*************************************************************************
3755 CALL soilmoist (debug_print,xlat,xlon,testptlat,testptlon,&
3756!-- input
3757 delt,nzs,nddzs,dtdzs,dtdzs2,riw, &
3758 zsmain,zshalf,diffu,hydro, &
3759 qsg,qvg,qcg,qcatm,qvatm,-infwater, &
3760 qkms,transp,zero, &
3761 zero,smelt,soilice,vegfrac, &
3762 snowfrac,one, &
3763!-- soil properties
3764 dqm,qmin,ref,ksat,ras,infmax, &
3765!-- output
3766 soilmois,soiliqw,mavail,runoff1, &
3767 runoff2,infiltrp)
3768
3769! endif
3770
3771!-- Restore land-use parameters if all snow is melted
3772 IF(snhei.EQ.zero) then
3773 tsnav=soilt-tfrz
3774 ENDIF
3775
3776! 21apr2009
3777! SNOM [mm] goes into the passed-in ACSNOM variable in the grid derived type
3778 snom=snom+smelt*delt*rhowater
3779!
3780!--- KEEPFR is 1 when the temperature and moisture in soil
3781!--- are both increasing. In this case soil ice should not
3782!--- be increasing according to the freezing curve.
3783!--- Some part of ice is melted, but additional water is
3784!--- getting frozen. Thus, only structure of frozen soil is
3785!--- changed, and phase changes are not affecting the heat
3786!--- transfer. This situation may happen when it rains on the
3787!--- frozen soil.
3788
3789 do k=1,nzs
3790 if (soilice(k).gt.zero) then
3791 if(tso(k).gt.told(k).and.soilmois(k).gt.smold(k)) then
3792 keepfr(k)=one
3793 else
3794 keepfr(k)=zero
3795 endif
3796 endif
3797 enddo
3798!--- THE DIAGNOSTICS OF SURFACE FLUXES
3799
3800 t3 = stbolt*soiltold*soiltold*soiltold
3801 upflux = t3 *0.5_kind_phys*(soiltold+soilt)
3802 xinet = emiss*(glw-upflux)
3803 hfx=-tkms*cp*rho*(tabs-soilt) &
3804 *(p1000mb*0.00001_kind_phys/patm)**rovcp
3805 IF (debug_print ) THEN
3806 print *,'potential temp HFX',hfx
3807 ENDIF
3808 hft=-tkms*cp*rho*(tabs-soilt)
3809 IF (debug_print ) THEN
3810 print *,'abs temp HFX',hft
3811 ENDIF
3812 q1 = - fq*ras* (qvatm - qsg)
3813 cmc2ms= zero
3814 IF (q1.LT.zero) THEN
3815! --- condensation
3816 edir1=zero
3817 ec1=zero
3818 ett1=zero
3819! --- condensation
3820 if(myj) then
3821!-- moisture flux for coupling with MYJ PBL
3822 eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*rhowater
3823 cst= cst-eeta*delt*vegfrac
3824 IF (debug_print ) THEN
3825 print *,'MYJ EETA cond', eeta
3826 ENDIF
3827 else ! myj
3828!-- actual moisture flux from RUC LSM
3829 dew=qkms*(qvatm-qsg)
3830 eeta= - rho*dew
3831 cst=cst+delt*dew*ras * vegfrac
3832 IF (debug_print ) THEN
3833 print *,'RUC LSM EETA cond',eeta
3834 ENDIF
3835 endif ! myj
3836 qfx= xlvm*eeta
3837 eeta= - rho*dew
3838 ELSE
3839! --- evaporation
3840 edir1 = q1*umveg *beta
3841 cmc2ms=cst/delt*ras
3842 ec1 = q1 * wetcan * vegfrac
3843
3844 cst=max(zero,cst-ec1 * delt)
3845
3846 IF (debug_print ) THEN
3847 print*,'Q1,umveg,beta',q1,umveg,beta
3848 print *,'wetcan,vegfrac',wetcan,vegfrac
3849 print *,'EC1,CMC2MS',ec1,cmc2ms
3850 ENDIF
3851
3852 if(myj) then
3853!-- moisture flux for coupling with MYJ PBL
3854 eeta=-(qkms*ras*(qvatm/(one+qvatm) - qsg/(one+qsg))*rhowater)*beta
3855 IF (debug_print ) THEN
3856 print *,'MYJ EETA', eeta*xlvm,eeta
3857 ENDIF
3858 else ! myj
3859! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
3860!-- actual moisture flux from RUC LSM
3861 eeta = (edir1 + ec1 + ett1)*rhowater
3862 IF (debug_print ) THEN
3863 print *,'RUC LSM EETA',eeta*xlvm,eeta
3864 ENDIF
3865 endif ! myj
3866 qfx= xlvm * eeta
3867 eeta = (edir1 + ec1 + ett1)*rhowater
3868 ENDIF
3869 s=snflx
3870 sublim=q1*rhowater !kg m-2 s-1
3871! Energy budget
3872 fltot=rnet-hft-xlvm*eeta-s-snoh-x
3873 IF (debug_print ) THEN
3874 print *,'SNOWSOIL - FLTOT,RNET,HFT,QFX,S,SNOH,X=',fltot,rnet,hft,xlvm*eeta,s,snoh,x
3875 print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac,beta',&
3876 edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac,beta
3877 ENDIF
3878
3879 222 CONTINUE
3880
3881 1123 FORMAT(i5,8f12.3)
3882 1133 FORMAT(i7,8e12.4)
3883 123 format(i6,f6.2,7f8.1)
3884 122 FORMAT(1x,2i3,6f8.1,f8.3,f8.2)
3885
3886!-------------------------------------------------------------------
3887 END SUBROUTINE snowsoil
3888!-------------------------------------------------------------------
3889
3895 SUBROUTINE snowseaice( debug_print,xlat,xlon, &
3896 i,j,isoil,delt,ktau,conflx,nzs,nddzs, &
3897 isncond_opt,isncovr_opt, &
3898 meltfactor,rhonewsn,SNHEI_CRIT, & ! new
3899 ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, &
3900 RHOSN,PATM,QVATM,QCATM, &
3901 GLW,GSW,EMISS,RNET, &
3902 QKMS,TKMS,RHO,myj, &
3903 ALB,ZNT, & !--- sea ice parameters
3904 tice,rhosice,capice,thdifice, &
3905 zsmain,zshalf,DTDZS,DTDZS2,tbq, &
3906 xlv,CP,rovcp,cw,stbolt,tabs, & !--- constants
3907 ilnb,snweprint,snheiprint,rsm,tso, & !--- output variables
3908 dew,soilt,soilt1,tsnav,qvg,qsg,qcg, &
3909 SMELT,SNOH,SNFLX,SNOM,eeta, &
3910 qfx,hfx,s,sublim,prcpl,fltot &
3911 )
3912!***************************************************************
3913! Solving energy budget for snow on sea ice and heat diffusion
3914! eqns. in snow and sea ice
3915!***************************************************************
3916
3917
3918 IMPLICIT NONE
3919!-------------------------------------------------------------------
3920!--- input variables
3921
3922 LOGICAL, INTENT(IN ) :: debug_print
3923 INTEGER, INTENT(IN ) :: ktau,nzs , &
3924 nddzs !nddzs=2*(nzs-2)
3925 INTEGER, INTENT(IN ) :: i,j,isoil,isncond_opt,isncovr_opt
3926
3927 real (kind_phys), INTENT(IN ) :: delt,conflx,prcpms, &
3928 rainf,newsnow,rhonewsn, &
3929 meltfactor,snhei_crit,xlat,xlon
3930 real :: rhonewcsn
3931
3932 LOGICAL, INTENT(IN ) :: myj
3933!--- 3-D Atmospheric variables
3934 real (kind_phys), &
3935 INTENT(IN ) :: patm, &
3936 qvatm, &
3937 qcatm
3938!--- 2-D variables
3939 real (kind_phys) , &
3940 INTENT(IN ) :: glw, &
3941 gsw, &
3942 rho, &
3943 qkms, &
3944 tkms
3945
3946!--- sea ice properties
3947 real (kind_phys), DIMENSION(1:NZS) , &
3948 INTENT(IN ) :: &
3949 tice, &
3950 rhosice, &
3951 capice, &
3952 thdifice
3953
3954 real (kind_phys), INTENT(IN ) :: &
3955 cw, &
3956 xlv
3957
3958 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: zsmain, &
3959 zshalf, &
3960 dtdzs2
3961
3962 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: dtdzs
3963
3964 real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: tbq
3965
3966!--- input/output variables
3967!-------- 3-d soil moisture and temperature
3968 real (kind_phys), DIMENSION( 1:nzs ) , &
3969 INTENT(INOUT) :: tso
3970
3971 INTEGER, INTENT(INOUT) :: iland
3972
3973
3974!-------- 2-d variables
3975 real (kind_phys) , &
3976 INTENT(INOUT) :: dew, &
3977 eeta, &
3978 rhosn, &
3979 sublim, &
3980 prcpl, &
3981 alb, &
3982 emiss, &
3983 znt, &
3984 qvg, &
3985 qsg, &
3986 qcg, &
3987 qfx, &
3988 hfx, &
3989 s, &
3990 snwe, &
3991 snhei, &
3992 smelt, &
3993 snom, &
3994 snoh, &
3995 snflx, &
3996 soilt, &
3997 soilt1, &
3998 snowfrac, &
3999 tsnav
4000
4001 INTEGER, INTENT(INOUT) :: ilnb
4002
4003 real (kind_phys), INTENT(OUT) :: rsm, &
4004 snweprint, &
4005 snheiprint
4006!--- Local variables
4007
4008
4009 INTEGER :: nzs1,nzs2,k,k1,kn,kk
4010 real (kind_phys) :: x,x1,x2,dzstop,ft,tn,denom
4011
4012 real (kind_phys) :: snth, newsn , &
4013 tabs, t3, upflux, xinet , &
4014 beta, snwepr,epdt,pp
4015 real (kind_phys) :: cp,rovcp,g0,lv,xlvm,stbolt,xlmelt , &
4016 epot,fltot,fq,hft,q1,ras,ci,cvw , &
4017 riw,deltsn,h
4018
4019 real (kind_phys) :: rhocsn,thdifsn, &
4020 xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn
4021
4022 real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn
4023 real (kind_phys) :: fso,fsn, &
4024 fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11, &
4025 fkq,r210,aa,bb,qs1,ts1,tq2,tx2, &
4026 tdenom,aa1,rhcs,h1,tsob, snprim, &
4027 snodif,soh,tnold,qgold,snohgnew
4028 real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso
4029
4030 real (kind_phys) :: rnet,rsmfrac,soiltfrac,hsn,icemelt,rr
4031 integer :: nmelt
4032
4033 real (kind_phys) :: keff, fact
4034
4035!-----------------------------------------------------------------
4036 xlmelt=con_hfus
4037!-- heat of sublimation of water vapor
4038 xlvm=xlv+xlmelt
4039
4040 !-- options for snow conductivity:
4041 !-- 1 - constant
4042 !-- opt 2 - Sturm et al., 1997
4043 keff = 0.265_kind_phys
4044
4045!--- SNOW flag -- ISICE
4046!--- DELTSN - is the threshold for splitting the snow layer into 2 layers.
4047!--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm,
4048!--- equivalent to 0.03 m SNWE. For other snow densities the threshold is
4049!--- computed using SNWE=0.03 m and current snow density.
4050!--- SNTH - the threshold below which the snow layer is combined with
4051!--- the top sea ice layer. SNTH is computed using snwe=0.016 m, and
4052!--- equals 4 cm for snow density 400 kg/m^3.
4053
4054 deltsn=0.05_kind_phys*rhowater/rhosn
4055 snth=0.01_kind_phys*rhowater/rhosn
4056
4057! For 2-layer snow model when the snow depth is marginlly higher than DELTSN,
4058! reset DELTSN to half of snow depth.
4059 IF(snhei.GE.deltsn+snth) THEN
4060 if(snhei-deltsn-snth.lt.snth) deltsn=0.5_kind_phys*(snhei-snth)
4061 IF (debug_print ) THEN
4062 print *,'DELTSN ICE is changed,deltsn,snhei,snth', &
4063 i,j, deltsn,snhei,snth
4064 ENDIF
4065 ENDIF
4066
4067 ci=rhoice*sheatice
4068 ras=rho*1.e-3_kind_dbl_prec ! rho/rhowater
4069 riw=rhoice*1.e-3_kind_dbl_prec ! rhoice/rhowater
4070 rsm=zero
4071
4072 xlmelt=con_hfus
4073 rhocsn=sheatsn * rhosn
4074!18apr08 - add rhonewcsn
4075 rhonewcsn=sheatsn * rhonewsn
4076
4077 if(isncond_opt == 1) then
4078 !-- old version thdifsn = 0.265/RHOCSN
4079 thdifsn = 0.265_kind_phys/rhocsn
4080 else
4081 !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997)
4082 !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652)
4083 fact = one
4084 if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then
4085 keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys
4086 else
4087 keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys
4088 endif
4089
4090 if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then
4091 !-- some areas with large snow depth have unrealistically
4092 !-- low snow density (in the Rockie's with snow depth > 1 m).
4093 !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs
4094 !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7
4095 !-- In future a better compaction scheme is needed for these areas.
4096 thdifsn = 4.431718e-7_kind_phys
4097 else
4098 thdifsn = keff/rhocsn * fact
4099 endif
4100 endif
4101
4102 ras=rho*1.e-3_kind_phys
4103
4104 soiltfrac=soilt
4105
4106 smelt=zero
4107 soh=zero
4108 snodif=zero
4109 snoh=zero
4110 snohgnew=zero
4111 rsm=zero
4112 rsmfrac=zero
4113 fsn=one
4114 fso=zero
4115 cvw=cw
4116
4117 nzs1=nzs-1
4118 nzs2=nzs-2
4119
4120 qgold=qsg
4121 tnold=soilt
4122 dzstop=one/(zsmain(2)-zsmain(1))
4123
4124 snweprint=zero
4125 snheiprint=zero
4126 prcpl=prcpms
4127
4128!*** DELTSN is the depth of the top layer of snow where
4129!*** there is a temperature gradient, the rest of the snow layer
4130!*** is considered to have constant temperature
4131
4132
4133 h=one
4134 smelt=zero
4135
4136 fq=qkms
4137 snhei=snwe*rhowater/rhosn
4138 snwepr=snwe
4139
4140! check if all snow can evaporate during DT
4141 beta=one
4142 epot = -fq*(qvatm-qsg)
4143 epdt = epot * ras *delt
4144 IF(epdt.GT.zero .and. snwepr.LE.epdt) THEN
4145 beta=snwepr/max(1.e-8_kind_phys,epdt)
4146 snwe=zero
4147 ENDIF
4148
4149!******************************************************************************
4150! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO
4151!******************************************************************************
4152
4153 cotso(1)=zero
4154 rhtso(1)=tso(nzs)
4155 DO 33 k=1,nzs2
4156 kn=nzs-k
4157 k1=2*kn-3
4158 x1=dtdzs(k1)*thdifice(kn-1)
4159 x2=dtdzs(k1+1)*thdifice(kn)
4160 ft=tso(kn)+x1*(tso(kn-1)-tso(kn)) &
4161 -x2*(tso(kn)-tso(kn+1))
4162 denom=1.+x1+x2-x2*cotso(k)
4163 cotso(k+1)=x1/denom
4164 rhtso(k+1)=(ft+x2*rhtso(k))/denom
4165 33 CONTINUE
4166!--- THE NZS element in COTSO and RHTSO will be for snow
4167!--- There will be 2 layers in snow if it is deeper than DELTSN+SNTH
4168 IF(snhei.GE.snth) then
4169 if(snhei.le.deltsn+snth) then
4170!-- 1-layer snow model
4171 ilnb=1
4172 snprim=max(snth,snhei)
4173 soilt1=tso(1)
4174 tsob=tso(1)
4175 xsn = delt/2._kind_phys/(zshalf(2)+0.5_kind_phys*snprim)
4176 ddzsn = xsn / snprim
4177 x1sn = ddzsn * thdifsn
4178 x2 = dtdzs(1)*thdifice(1)
4179 ft = tso(1)+x1sn*(soilt-tso(1)) &
4180 -x2*(tso(1)-tso(2))
4181 denom = one + x1sn + x2 -x2*cotso(nzs1)
4182 cotso(nzs)=x1sn/denom
4183 rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom
4184 cotsn=cotso(nzs)
4185 rhtsn=rhtso(nzs)
4186!*** Average temperature of snow pack (C)
4187 tsnav=0.5_kind_phys*(soilt+tso(1)) &
4188 -tfrz
4189
4190 else
4191!-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth
4192 ilnb=2
4193 snprim=deltsn
4194 tsob=soilt1
4195 xsn = delt/2._kind_phys/(0.5_kind_phys*snhei)
4196 xsn1= delt/2._kind_phys/(zshalf(2)+0.5_kind_phys*(snhei-deltsn))
4197 ddzsn = xsn / deltsn
4198 ddzsn1 = xsn1 / (snhei-deltsn)
4199 x1sn = ddzsn * thdifsn
4200 x1sn1 = ddzsn1 * thdifsn
4201 x2 = dtdzs(1)*thdifice(1)
4202 ft = tso(1)+x1sn1*(soilt1-tso(1)) &
4203 -x2*(tso(1)-tso(2))
4204 denom = one + x1sn1 + x2 - x2*cotso(nzs1)
4205 cotso(nzs)=x1sn1/denom
4206 rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom
4207 ftsnow = soilt1+x1sn*(soilt-soilt1) &
4208 -x1sn1*(soilt1-tso(1))
4209 denomsn = 1. + x1sn + x1sn1 - x1sn1*cotso(nzs)
4210 cotsn=x1sn/denomsn
4211 rhtsn=(ftsnow+x1sn1*rhtso(nzs))/denomsn
4212!*** Average temperature of snow pack (C)
4213 tsnav=0.5_kind_phys/snhei*((soilt+soilt1)*deltsn &
4214 +(soilt1+tso(1))*(snhei-deltsn)) &
4215 -tfrz
4216 endif
4217 ENDIF
4218
4219 IF(snhei.LT.snth.AND.snhei.GT.zero) then
4220!--- snow is too thin to be treated separately, therefore it
4221!--- is combined with the first sea ice layer.
4222 snprim=snhei+zsmain(2)
4223 fsn=snhei/snprim
4224 fso=one-fsn
4225 soilt1=tso(1)
4226 tsob=tso(2)
4227 xsn = delt/2._kind_phys/((zshalf(3)-zsmain(2))+0.5_kind_phys*snprim)
4228 ddzsn = xsn /snprim
4229 x1sn = ddzsn * (fsn*thdifsn+fso*thdifice(1))
4230 x2=dtdzs(2)*thdifice(2)
4231 ft=tso(2)+x1sn*(soilt-tso(2))- &
4232 x2*(tso(2)-tso(3))
4233 denom = one + x1sn + x2 - x2*cotso(nzs-2)
4234 cotso(nzs1) = x1sn/denom
4235 rhtso(nzs1)=(ft+x2*rhtso(nzs-2))/denom
4236 tsnav=0.5_kind_phys*(soilt+tso(1)) &
4237 -tfrz
4238 cotso(nzs)=cotso(nzs1)
4239 rhtso(nzs)=rhtso(nzs1)
4240 cotsn=cotso(nzs)
4241 rhtsn=rhtso(nzs)
4242 ENDIF
4243
4244!************************************************************************
4245!--- THE HEAT BALANCE EQUATION
4246!18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes
4247 nmelt=0
4248 snoh=zero
4249
4250 epot=-qkms*(qvatm-qsg)
4251 rhcs=capice(1)
4252 h=one
4253 fkt=tkms
4254 d1=cotso(nzs1)
4255 d2=rhtso(nzs1)
4256 tn=soilt
4257 d9=thdifice(1)*rhcs*dzstop
4258 d10=tkms*cp*rho
4259 r211=.5_kind_phys*conflx/delt
4260 r21=r211*cp*rho
4261 r22=.5_kind_phys/(thdifice(1)*delt*dzstop**2)
4262 r6=emiss *stbolt*.5_kind_phys*tn**4
4263 r7=r6/tn
4264 d11=rnet+r6
4265
4266 IF(snhei.GE.snth) THEN
4267 if(snhei.le.deltsn+snth) then
4268!--- 1-layer snow
4269 d1sn = cotso(nzs)
4270 d2sn = rhtso(nzs)
4271 else
4272!--- 2-layer snow
4273 d1sn = cotsn
4274 d2sn = rhtsn
4275 endif
4276 d9sn= thdifsn*rhocsn / snprim
4277 r22sn = snprim*snprim*0.5_kind_phys/(thdifsn*delt)
4278 ENDIF
4279
4280 IF(snhei.LT.snth.AND.snhei.GT.zero) then
4281!--- thin snow is combined with sea ice
4282 d1sn = d1
4283 d2sn = d2
4284 d9sn = (fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)/ &
4285 snprim
4286 r22sn = snprim*snprim*0.5_kind_phys &
4287 /((fsn*thdifsn+fso*thdifice(1))*delt)
4288 ENDIF
4289
4290 IF(snhei.eq.zero)then
4291!--- all snow is sublimated
4292 d9sn = d9
4293 r22sn = r22
4294 d1sn = d1
4295 d2sn = d2
4296 ENDIF
4297
4298
4299!---- TDENOM for snow
4300 tdenom = d9sn*(one-d1sn +r22sn)+d10+r21+r7 &
4301 +rainf*cvw*prcpms &
4302 +rhonewcsn*newsnow/delt
4303
4304 fkq=qkms*rho
4305 r210=r211*rho
4306 aa=xlvm*(beta*fkq+r210)/tdenom
4307 bb=(d10*tabs+r21*tn+xlvm*(qvatm* &
4308 (beta*fkq) &
4309 +r210*qvg)+d11+d9sn*(d2sn+r22sn*tn) &
4310 +rainf*cvw*prcpms*max(tfrz,tabs) &
4311 + rhonewcsn*newsnow/delt*min(tfrz,tabs) &
4312 )/tdenom
4313 aa1=aa
4314 pp=patm*1.e3_kind_phys
4315 aa1=aa1/pp
4316!18apr08 - the iteration start point
4317 212 continue
4318 bb=bb-snoh/tdenom
4319 IF (debug_print ) THEN
4320 print *,'VILKA-SNOW on SEAICE'
4321 print *,'tn,aa1,bb,pp,fkq,r210', &
4322 tn,aa1,bb,pp,fkq,r210
4323 print *,'TABS,QVATM,TN,QVG=',tabs,qvatm,tn,qvg
4324 ENDIF
4325
4326 CALL vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil,xlat,xlon)
4327!--- it is saturation over snow
4328 qvg=qs1
4329 qsg=qs1
4330 qcg=zero
4331
4332!--- SOILT - skin temperature of snow on ice
4333 soilt=ts1
4334 if(nmelt==1 .and. snowfrac==one) then
4335 soilt = min(tfrz,soilt)
4336 endif
4337
4338 IF (debug_print ) THEN
4339 print *,' AFTER VILKA-SNOW on SEAICE'
4340 print *,' TS1,QS1: ', ts1,qs1
4341 ENDIF
4342! Solution for temperature at 7.5 cm depth and snow-seaice interface
4343 IF(snhei.GE.snth) THEN
4344 if(snhei.gt.deltsn+snth) then
4345!-- 2-layer snow model
4346 soilt1=min(tfrz,rhtsn+cotsn*soilt)
4347 tso(1)=min(con_tice,(rhtso(nzs)+cotso(nzs)*soilt1))
4348 tsob=soilt1
4349 else
4350!-- 1 layer in snow
4351 tso(1)=min(con_tice,(rhtso(nzs)+cotso(nzs)*soilt))
4352 soilt1=tso(1)
4353 tsob=tso(1)
4354 endif
4355 ELSEIF (snhei > zero .and. snhei < snth) THEN
4356! blended
4357 tso(2)=min(con_tice,(rhtso(nzs1)+cotso(nzs1)*soilt))
4358 tso(1)=min(con_tice,(tso(2)+(soilt-tso(2))*fso))
4359 soilt1=tso(1)
4360 tsob=tso(2)
4361 ELSE
4362! snow is melted
4363 tso(1)=min(con_tice,soilt)
4364 soilt1=min(con_tice,soilt)
4365 tsob=tso(1)
4366 ENDIF
4367!---- Final solution for TSO in sea ice
4368 IF (snhei > zero .and. snhei < snth) THEN
4369! blended or snow is melted
4370 DO k=3,nzs
4371 kk=nzs-k+1
4372 tso(k)=min(con_tice,rhtso(kk)+cotso(kk)*tso(k-1))
4373 END DO
4374 ELSE
4375 DO k=2,nzs
4376 kk=nzs-k+1
4377 tso(k)=min(con_tice,rhtso(kk)+cotso(kk)*tso(k-1))
4378 END DO
4379 ENDIF
4380!--- For thin snow layer combined with the top soil layer
4381!--- TSO(i,j,1) is computed by linear interpolation between SOILT
4382!--- and TSO(i,j,2)
4383! if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then
4384! tso(1)=min(271.4,tso(2)+(soilt-tso(2))*fso)
4385! soilt1=tso(1)
4386! tsob = tso(2)
4387! endif
4388
4389 if(nmelt.eq.1) go to 220
4390
4391!--- IF SOILT > tfrz F then melting of snow can happen
4392! if all snow can evaporate, then there is nothing to melt
4393 IF(soilt>tfrz .AND. beta==one .AND. snhei>zero) THEN
4394!
4395 nmelt = 1
4396 soiltfrac=snowfrac*tfrz+(1.-snowfrac)*min(con_tice,soilt)
4397
4398 qsg= qsn(soiltfrac,tbq)/pp
4399 t3 = stbolt*tnold*tnold*tnold
4400 upflux = t3 * 0.5_kind_phys*(tnold+soiltfrac)
4401 xinet = emiss*(glw-upflux)
4402 epot = -qkms*(qvatm-qsg)
4403 q1=epot*ras
4404
4405 IF (q1.LE.zero) THEN
4406! --- condensation
4407 dew=-epot
4408
4409 qfx= xlvm*rho*dew
4410 eeta=qfx/xlvm
4411 ELSE
4412! --- evaporation
4413 eeta = q1 * beta * rhowater
4414! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
4415 qfx= - xlvm * eeta
4416 ENDIF
4417
4418 hfx=d10*(tabs-soiltfrac)
4419
4420 IF(snhei.GE.snth)then
4421 soh=thdifsn*rhocsn*(soiltfrac-tsob)/snprim
4422 snflx=soh
4423 ELSE
4424 soh=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)* &
4425 (soiltfrac-tsob)/snprim
4426 snflx=soh
4427 ENDIF
4428 x= (r21+d9sn*r22sn)*(soiltfrac-tnold) + &
4429 xlvm*r210*(qsg-qgold)
4430!-- SNOH is energy flux of snow phase change
4431 snoh=rnet+qfx +hfx &
4432 +rhonewcsn*newsnow/delt*(min(tfrz,tabs)-soiltfrac) &
4433 -soh-x+rainf*cvw*prcpms* &
4434 (max(tfrz,tabs)-soiltfrac)
4435
4436 IF (debug_print ) THEN
4437 print *,'SNOWSEAICE melt I,J,SNOH,RNET,QFX,HFX,SOH,X',i,j,snoh,rnet,qfx,hfx,soh,x
4438 print *,'RHOnewCSN*NEWSNOW/DELT*(min(tfrz,TABS)-soiltfrac)', &
4439 rhonewcsn*newsnow/delt*(min(tfrz,tabs)-soiltfrac)
4440 print *,'RAINF*CVW*PRCPMS*(max(tfrz,TABS)-soiltfrac)', &
4441 rainf*cvw*prcpms*(max(tfrz,tabs)-soiltfrac)
4442 ENDIF
4443 snoh=amax1(zero,snoh)
4444!-- SMELT is speed of melting in M/S
4445 smelt= snoh /xlmelt*1.e-3_kind_phys
4446 smelt=amin1(smelt,snwepr/delt-beta*epot*ras)
4447 smelt=amax1(zero,smelt)
4448
4449 IF (debug_print ) THEN
4450 print *,'1-SMELT i,j',smelt,i,j
4451 ENDIF
4452!18apr08 - Egglston limit
4453 smelt= amin1(smelt,delt/60._kind_phys* 5.6e-8_kind_phys*meltfactor*max(one,(soilt-tfrz))) ! SnowMIP
4454 IF (debug_print ) THEN
4455 print *,'2-SMELT i,j',smelt,i,j
4456 ENDIF
4457
4458! rr - potential melting
4459 rr=snwepr/delt-beta*epot*ras
4460 smelt=min(smelt,rr)
4461 IF (debug_print ) THEN
4462 print *,'3- SMELT i,j,smelt,rr',i,j,smelt,rr
4463 ENDIF
4464 snohgnew=smelt*xlmelt*1.e3
4465 snodif=amax1(zero,(snoh-snohgnew))
4466
4467 snoh=snohgnew
4468
4469 IF (debug_print ) THEN
4470 print*,'soiltfrac,soilt,SNOHGNEW,SNODIF=', &
4471 i,j,soiltfrac,soilt,snohgnew,snodif
4472 print *,'SNOH,SNODIF',snoh,snodif
4473 ENDIF
4474
4475!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack
4476 rsmfrac=min(0.18_kind_phys,(max(0.08_kind_phys,snwepr/0.10_kind_phys*0.13_kind_phys)))
4477 if(snhei > 0.01_kind_phys) then
4478 rsm=rsmfrac*smelt*delt
4479 else
4480! do not keep melted water if snow depth is less that 1 cm
4481 rsm=zero
4482 endif
4483!18apr08 rsm is part of melted water that stays in snow as liquid
4484 smelt=amax1(zero,smelt-rsm/delt)
4485 IF (debug_print ) THEN
4486 print *,'4-SMELT i,j,smelt,rsm,snwepr,rsmfrac', &
4487 i,j,smelt,rsm,snwepr,rsmfrac
4488 ENDIF
4489
4490!-- update liquid equivalent of snow depth
4491!-- for evaporation and snow melt
4492 snwe = amax1(zero,(snwepr- &
4493 (smelt+beta*epot*ras)*delt &
4494 ) )
4495 soilt=soiltfrac
4496!--- If there is no snow melting then just evaporation
4497!--- or condensation changes SNWE
4498 ELSE
4499 if(snhei > zero.and. beta == one) then
4500 epot=-qkms*(qvatm-qsg)
4501 snwe = amax1(zero,(snwepr- &
4502 beta*epot*ras*delt))
4503 else
4504 snwe = zero
4505 endif
4506
4507 ENDIF
4508
4509! no iteration for snow on sea ice, because it will produce
4510! skin temperature higher than it is possible with snow on sea ice
4511! if(nmelt.eq.1) goto 212 ! second iteration
4512 220 continue
4513
4514 if(smelt > zero .and. rsm > zero) then
4515 if(snwe.le.rsm) then
4516 IF (debug_print ) THEN
4517 print *,'SEAICE SNWE<RSM snwe,rsm,smelt*delt,epot*ras*delt,beta', &
4518 snwe,rsm,smelt*delt,epot*ras*delt,beta
4519 ENDIF
4520 else
4521!*** Update snow density on effect of snow melt, melted
4522!*** from the top of the snow. 13% of melted water
4523!*** remains in the pack and changes its density.
4524!*** Eq. 9 (with my correction) in Koren et al. (1999)
4525
4526 xsn=(rhosn*(snwe-rsm)+rhowater*rsm)/ &
4527 snwe
4528 rhosn=min(max(58.8_kind_phys,xsn),500._kind_phys)
4529
4530 rhocsn=sheatsn* rhosn
4531 if(isncond_opt == 1) then
4532 !-- old version thdifsn = 0.265/RHOCSN
4533 thdifsn = 0.265_kind_phys/rhocsn
4534 else
4535 !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997)
4536 !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652)
4537 fact = one
4538 if(rhosn < 156._kind_phys .or. (newsn > zero .and. rhonewsn < 156._kind_phys)) then
4539 keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys
4540 else
4541 keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys
4542 endif
4543
4544 if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then
4545 !-- some areas with large snow depth have unrealistically
4546 !-- low snow density (in the Rockie's with snow depth > 1 m).
4547 !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs
4548 !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7
4549 !-- In future a better compaction scheme is needed for these areas.
4550 thdifsn = 4.431718e-7_kind_phys
4551 else
4552 thdifsn = keff/rhocsn * fact
4553 endif
4554 endif
4555
4556 endif
4557 endif
4558
4559 snweprint=snwe
4560!--- if VEGFRAC.ne.0. then some snow stays on the canopy
4561!--- and should be added to SNWE for water conservation
4562! +VEGFRAC*cst
4563 snheiprint=snweprint*rhowater / rhosn
4564
4565 IF (debug_print ) THEN
4566print *, 'snweprint : ',snweprint
4567print *, 'D9SN,SOILT,TSOB : ', d9sn,soilt,tsob
4568 ENDIF
4569 IF(snhei.GT.zero) THEN
4570 if(ilnb.gt.1) then
4571 tsnav=0.5_kind_phys/snhei*((soilt+soilt1)*deltsn &
4572 +(soilt1+tso(1))*(snhei-deltsn)) &
4573 -tfrz
4574 else
4575 tsnav=0.5_kind_phys*(soilt+tso(1)) - tfrz
4576 endif
4577 ENDIF
4578!--- RECALCULATION OF DEW USING NEW VALUE OF QSG
4579 dew=zero
4580 pp=patm*1.e3_kind_phys
4581 qsg= qsn(soilt,tbq)/pp
4582 epot = -fq*(qvatm-qsg)
4583 IF(epot.LT.zero) THEN
4584! Sublimation
4585 dew=-epot
4586 ENDIF
4587
4588 snom=snom+smelt*delt*rhowater
4589
4590!--- THE DIAGNOSTICS OF SURFACE FLUXES
4591
4592 t3 = stbolt*tnold*tnold*tnold
4593 upflux = t3 *0.5_kind_phys*(soilt+tnold)
4594 xinet = emiss*(glw-upflux)
4595 hft=-tkms*cp*rho*(tabs-soilt)
4596 hfx=-tkms*cp*rho*(tabs-soilt) &
4597 *(p1000mb*0.00001_kind_phys/patm)**rovcp
4598 q1 = - fq*ras* (qvatm - qsg)
4599 IF (q1.LT.zero) THEN
4600! --- condensation
4601 if(myj) then
4602!-- moisture flux for coupling with MYJ PBL
4603 eeta=-qkms*ras*(qvatm/(1.+qvatm) - qsg/(1.+qsg))*rhowater
4604 else ! myj
4605!-- actual moisture flux from RUC LSM
4606 dew=qkms*(qvatm-qsg)
4607 eeta= - rho*dew
4608 endif ! myj
4609 qfx= xlvm*eeta
4610 eeta= - rho*dew
4611 sublim = eeta
4612 ELSE
4613! --- evaporation
4614 if(myj) then
4615!-- moisture flux for coupling with MYJ PBL
4616 eeta=-qkms*ras*beta*(qvatm/(1.+qvatm) - qvg/(1.+qvg))*rhowater
4617 else ! myj
4618! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
4619!-- actual moisture flux from RUC LSM
4620 eeta = q1*beta*rhowater
4621 endif ! myj
4622 qfx= xlvm * eeta
4623 eeta = q1*beta*rhowater
4624 sublim = eeta
4625 ENDIF
4626
4627 icemelt=zero
4628 IF(snhei.GE.snth)then
4629 s=thdifsn*rhocsn*(soilt-tsob)/snprim
4630 snflx=s
4631 ELSEIF(snhei.lt.snth.and.snhei.GT.zero) then
4632 s=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)* &
4633 (soilt-tsob)/snprim
4634 snflx=s
4635 IF (debug_print ) THEN
4636 print *,'SNOW is thin, snflx',i,j,snflx
4637 ENDIF
4638 ELSE
4639 snflx=d9sn*(soilt-tsob)
4640 IF (debug_print ) THEN
4641 print *,'SNOW is GONE, snflx',i,j,snflx
4642 ENDIF
4643 ENDIF
4644
4645 snhei=snwe *rhowater / rhosn
4646
4647 IF (debug_print ) THEN
4648 print *,'SNHEI,SNOH',i,j,snhei,snoh
4649 ENDIF
4650!
4651 x= (r21+d9sn*r22sn)*(soilt-tnold) + &
4652 xlvm*r210*(qsg-qgold)
4653 IF (debug_print ) THEN
4654 print *,'SNOWSEAICE storage ',i,j,x
4655 print *,'R21,D9sn,r22sn,soiltfrac,tnold,qsg,qgold,snprim', &
4656 r21,d9sn,r22sn,soiltfrac,tnold,qsg,qgold,snprim
4657 ENDIF
4658 x=x &
4659 -rhonewcsn*newsnow/delt*(min(tfrz,tabs)-soilt) &
4660 -rainf*cvw*prcpms*(max(tfrz,tabs)-soilt)
4661
4662! -- excess energy is spent on ice melt
4663 icemelt = rnet-hft-xlvm*eeta-s-snoh-x
4664 IF (debug_print ) THEN
4665 print *,'SNOWSEAICE icemelt=',icemelt
4666 ENDIF
4667
4668 fltot=rnet-hft-xlvm*eeta-s-snoh-x-icemelt
4669 IF (debug_print ) THEN
4670 print *,'i,j,snhei,qsg,soilt,soilt1,tso,TABS,QVATM', &
4671 i,j,snhei,qsg,soilt,soilt1,tso,tabs,qvatm
4672 print *,'SNOWSEAICE - FLTOT,RNET,HFT,QFX,S,SNOH,icemelt,snodif,X,SOILT=' &
4673 ,fltot,rnet,hft,xlvm*eeta,s,snoh,icemelt,snodif,x,soilt
4674 ENDIF
4675!-- Restore sea-ice parameters if snow is less than threshold
4676 IF(snhei.EQ.zero) then
4677 tsnav=soilt-tfrz
4678 emiss=0.98_kind_phys
4679 znt=0.011_kind_phys
4680 alb=0.55_kind_phys
4681 ENDIF
4682
4683!------------------------------------------------------------------------
4684!------------------------------------------------------------------------
4685 END SUBROUTINE snowseaice
4686!------------------------------------------------------------------------
4687
4691 SUBROUTINE soiltemp( debug_print,xlat,xlon,testptlat,testptlon,&
4692 i,j,iland,isoil, & !--- input variables
4693 delt,ktau,conflx,nzs,nddzs,nroot, &
4694 PRCPMS,RAINF,PATM,TABS,QVATM,QCATM, &
4695 EMISS,RNET, &
4696 QKMS,TKMS,PC,RHO,VEGFRAC,lai, &
4697 THDIF,CAP,DRYCAN,WETCAN, &
4698 TRANSUM,DEW,MAVAIL,soilres,alfa, &
4699 DQM,QMIN,BCLH, & !---soil fixed fields
4700 ZSMAIN,ZSHALF,DTDZS,TBQ, &
4701 XLV,CP,G0_P,CVW,STBOLT, & !--- constants
4702 TSO,SOILT,QVG,QSG,QCG,X) !---output variables
4703
4704!*************************************************************
4705! Energy budget equation and heat diffusion eqn are
4706! solved here and
4707!
4708! DELT - time step (s)
4709! ktau - number of time step
4710! CONFLX - depth of constant flux layer (m)
4711! IME, JME, KME, NZS - dimensions of the domain
4712! NROOT - number of levels within the root zone
4713! PRCPMS - precipitation rate in m/s
4714! COTSO, RHTSO - coefficients for implicit solution of
4715! heat diffusion equation
4716! THDIF - thermal diffusivity (m^2/s)
4717! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of
4718! water vapor and cloud at the ground
4719! surface, respectively (kg/kg)
4720! PATM - pressure [bar]
4721! QC3D,QV3D - cloud and water vapor mixing ratio
4722! at the first atm. level (kg/kg)
4723! EMISS,RNET - emissivity (0-1) of the ground surface and net
4724! radiation at the surface (W/m^2)
4725! QKMS - exchange coefficient for water vapor in the
4726! surface layer (m/s)
4727! TKMS - exchange coefficient for heat in the surface
4728! layer (m/s)
4729! PC - plant coefficient (resistance)
4730! RHO - density of atmosphere near surface (kg/m^3)
4731! VEGFRAC - greeness fraction (0-1)
4732! CAP - volumetric heat capacity (J/m^3/K)
4733! DRYCAN - dry fraction of vegetated area where
4734! transpiration may take place (0-1)
4735! WETCAN - fraction of vegetated area covered by canopy
4736! water (0-1)
4737! TRANSUM - transpiration function integrated over the
4738! rooting zone (m)
4739! DEW - dew in kg/m^2s
4740! MAVAIL - fraction of maximum soil moisture in the top
4741! layer (0-1)
4742! ZSMAIN - main levels in soil (m)
4743! ZSHALF - middle of the soil layers (m)
4744! DTDZS - dt/(2.*dzshalf*dzmain)
4745! TBQ - table to define saturated mixing ration
4746! of water vapor for given temperature and pressure
4747! TSO - soil temperature (K)
4748! SOILT - skin temperature (K)
4749!
4750!****************************************************************
4751
4752 IMPLICIT NONE
4753!-----------------------------------------------------------------
4754
4755!--- input variables
4756
4757 LOGICAL, INTENT(IN ) :: debug_print
4758 INTEGER, INTENT(IN ) :: nroot,ktau,nzs , &
4759 nddzs !nddzs=2*(nzs-2)
4760 INTEGER, INTENT(IN ) :: i,j,iland,isoil
4761 real (kind_phys), INTENT(IN ) :: delt,conflx,prcpms, rainf
4762 real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon
4763 real (kind_phys), INTENT(INOUT) :: drycan,wetcan,transum
4764!--- 3-D Atmospheric variables
4765 real (kind_phys), &
4766 INTENT(IN ) :: patm, &
4767 qvatm, &
4768 qcatm
4769!--- 2-D variables
4770 real (kind_phys) , &
4771 INTENT(IN ) :: &
4772 emiss, &
4773 rho, &
4774 rnet, &
4775 pc, &
4776 vegfrac, &
4777 lai, &
4778 dew, &
4779 qkms, &
4780 tkms
4781
4782!--- soil properties
4783 real (kind_phys) , &
4784 INTENT(IN ) :: &
4785 bclh, &
4786 dqm, &
4787 qmin
4788 real (kind_phys) , &
4789 INTENT(IN ) :: &
4790 soilres,alfa
4791
4792
4793 real (kind_phys), INTENT(IN ) :: cp, &
4794 cvw, &
4795 xlv, &
4796 stbolt, &
4797 tabs, &
4798 g0_p
4799
4800
4801 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: zsmain, &
4802 zshalf, &
4803 thdif, &
4804 cap
4805
4806 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: dtdzs
4807
4808 real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: tbq
4809
4810
4811!--- input/output variables
4812!-------- 3-d soil moisture and temperature
4813 real (kind_phys), DIMENSION( 1:nzs ) , &
4814 INTENT(INOUT) :: tso
4815
4816!-------- 2-d variables
4817 real (kind_phys) , &
4818 INTENT(INOUT) :: &
4819 mavail, &
4820 qvg, &
4821 qsg, &
4822 qcg, &
4823 soilt
4824
4825
4826!--- Local variables
4827
4828 real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph , &
4829 tn,trans,umveg,denom,fex
4830
4831 real (kind_phys) :: fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11, &
4832 pi,h,fkq,r210,aa,bb,pp,q1,qs1,ts1,tq2,tx2 , &
4833 tdenom
4834
4835 real (kind_phys) :: c,cc,aa1,rhcs,h1, qgold
4836
4837 real (kind_phys), DIMENSION(1:NZS) :: cotso,rhtso
4838
4839 INTEGER :: nzs1,nzs2,k,k1,kn,kk, iter
4840
4841
4842!-----------------------------------------------------------------
4843
4844 iter=0
4845
4846 nzs1=nzs-1
4847 nzs2=nzs-2
4848 dzstop=1./(zsmain(2)-zsmain(1))
4849
4850 qgold=qvg
4851
4852 do k=1,nzs
4853 cotso(k)=zero
4854 rhtso(k)=zero
4855 enddo
4856!******************************************************************************
4857! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO
4858!******************************************************************************
4859 cotso(1)=zero
4860 rhtso(1)=tso(nzs)
4861 DO k=1,nzs2
4862 kn=nzs-k
4863 k1=2*kn-3
4864 x1=dtdzs(k1)*thdif(kn-1)
4865 x2=dtdzs(k1+1)*thdif(kn)
4866 ft=tso(kn)+x1*(tso(kn-1)-tso(kn)) &
4867 -x2*(tso(kn)-tso(kn+1))
4868 denom=1.+x1+x2-x2*cotso(k)
4869 cotso(k+1)=x1/denom
4870 rhtso(k+1)=(ft+x2*rhtso(k))/denom
4871 END DO
4872
4873!************************************************************************
4874!--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26)
4875
4876 rhcs=cap(1)
4877
4878 h=mavail
4879
4880 trans=transum*drycan/zshalf(nroot+1)
4881 can=wetcan+trans
4882 umveg=(1.-vegfrac) * soilres
4883 2111 continue
4884 fkt=tkms
4885 d1=cotso(nzs1)
4886 d2=rhtso(nzs1)
4887 tn=soilt
4888 d9=thdif(1)*rhcs*dzstop
4889 d10=tkms*cp*rho
4890 r211=.5_kind_phys*conflx/delt
4891 r21=r211*cp*rho
4892 r22=.5_kind_phys/(thdif(1)*delt*dzstop**2)
4893 r6=emiss *stbolt*.5_kind_phys*tn**4
4894 r7=r6/tn
4895 d11=rnet+r6
4896 tdenom=d9*(one-d1+r22)+d10+r21+r7 &
4897 +rainf*cvw*prcpms
4898 fkq=qkms*rho
4899 r210=r211*rho
4900 c=vegfrac*fkq*can
4901 cc=c*xlv/tdenom
4902 aa=xlv*(fkq*umveg+r210)/tdenom
4903 bb=(d10*tabs+r21*tn+xlv*(qvatm* &
4904 (fkq*umveg+c) &
4905 +r210*qvg)+d11+d9*(d2+r22*tn) &
4906 +rainf*cvw*prcpms*max(tfrz,tabs) &
4907 )/tdenom
4908 aa1=aa+cc
4909 pp=patm*1.e3_kind_phys
4910 aa1=aa1/pp
4911 CALL vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil,xlat,xlon)
4912 tq2=qvatm
4913 tx2=tq2*(one-h)
4914 q1=tx2+h*qs1
4915 IF (debug_print ) THEN
4916 print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',ts1,qs1,tq2,h,tx2,q1
4917 ENDIF
4918 IF(q1.LT.qs1) GOTO 100
4919!--- if no saturation - goto 100
4920!--- if saturation - goto 90
4921 90 qvg=qs1
4922 qsg=qs1
4923 tso(1)=ts1
4924 qcg=max(zero,q1-qs1)
4925 IF (debug_print ) THEN
4926 print *,'90 QVG,QSG,QCG,TSO(1)',qvg,qsg,qcg,tso(1)
4927 ENDIF
4928
4929 GOTO 200
4930 100 bb=bb-aa*tx2
4931 aa=(aa*h+cc)/pp
4932
4933 CALL vilka(tn,aa,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil,xlat,xlon)
4934 q1=tx2+h*qs1
4935 IF (debug_print ) THEN
4936! if(i.eq.279.and.j.eq.263) then
4937 print *,'VILKA2 - TS1,QS1,TQ2,H,TX2,Q1',ts1,qs1,tq2,h,tx2,q1
4938 ENDIF
4939 IF(q1.GE.qs1) GOTO 90
4940 qsg=qs1
4941 qvg=q1
4942! if( QS1>QVATM .and. QVATM > QVG) then
4943 ! very dry soil
4944 ! print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1
4945 ! QVG = QVATM
4946! endif
4947 tso(1)=ts1
4948 qcg=zero
4949 200 CONTINUE
4950 IF (debug_print ) THEN
4951 print *,'200 QVG,QSG,QCG,TSO(1)',qvg,qsg,qcg,tso(1)
4952 ENDIF
4953 IF (debug_print ) THEN
4954 if(iter == 1) then
4955 print *,'QVATM,QVG,QSG,QCG,TS1',qvatm,qvg,qsg,qcg,ts1
4956 endif
4957 ENDIF
4958
4959!--- SOILT - skin temperature
4960 soilt=ts1
4961
4962!---- Final solution for soil temperature - TSO
4963 DO k=2,nzs
4964 kk=nzs-k+1
4965 tso(k)=rhtso(kk)+cotso(kk)*tso(k-1)
4966 END DO
4967
4968 x= (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(soilt-tn) + &
4969 xlv*rho*r211*(qvg-qgold)
4970
4971 IF (debug_print ) THEN
4972 print*,'SOILTEMP storage, i,j,x,soilt,tn,qvg,qvgold', &
4973 i,j,x,soilt,tn,qvg,qgold
4974 print *,'TEMP term (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN)',&
4975 (cp*rho*r211+rhcs*zsmain(2)*0.5_kind_phys/delt)*(soilt-tn)
4976 print *,'QV term XLV*rho*r211*(QVG-QGOLD)',xlv*rho*r211*(qvg-qgold)
4977 ENDIF
4978 x=x &
4979! "heat" from rain
4980 -rainf*cvw*prcpms*(max(tfrz,tabs)-soilt)
4981
4982 IF (debug_print ) THEN
4983 print *,'x=',x
4984 ENDIF
4985
4986!--------------------------------------------------------------------
4987 END SUBROUTINE soiltemp
4988!--------------------------------------------------------------------
4989
4993 SUBROUTINE snowtemp( debug_print,xlat,xlon, &
4994 testptlat,testptlon,i,j,iland,isoil, & !--- input variables
4995 delt,ktau,conflx,nzs,nddzs,nroot, &
4996 isncond_opt,isncovr_opt, &
4997 snwe,snwepr,snhei,newsnow,snowfrac,snhei_crit, &
4998 beta,deltsn,snth,rhosn,rhonewsn,meltfactor, & ! add meltfactor
4999 PRCPMS,RAINF, &
5000 PATM,TABS,QVATM,QCATM, &
5001 GLW,GSW,EMISS,RNET, &
5002 QKMS,TKMS,PC,RHO,VEGFRAC, &
5003 THDIF,CAP,DRYCAN,WETCAN,CST, &
5004 TRANF,TRANSUM,DEW,MAVAIL, &
5005 DQM,QMIN,PSIS,BCLH, & !--- soil fixed fields
5006 ZSMAIN,ZSHALF,DTDZS,TBQ, &
5007 XLVM,CP,rovcp,G0_P,CVW,STBOLT, & !--- constants
5008 SNWEPRINT,SNHEIPRINT,RSM, & !--- output variables
5009 TSO,SOILT,SOILT1,TSNAV,QVG,QSG,QCG, &
5010 SMELT,SNOH,SNFLX,S,ILNB,X)
5011
5012!********************************************************************
5013! Energy budget equation and heat diffusion eqn are
5014! solved here to obtain snow and soil temperatures
5015!
5016! DELT - time step (s)
5017! ktau - number of time step
5018! CONFLX - depth of constant flux layer (m)
5019! IME, JME, KME, NZS - dimensions of the domain
5020! NROOT - number of levels within the root zone
5021! PRCPMS - precipitation rate in m/s
5022! COTSO, RHTSO - coefficients for implicit solution of
5023! heat diffusion equation
5024! THDIF - thermal diffusivity (W/m/K)
5025! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of
5026! water vapor and cloud at the ground
5027! surface, respectively (kg/kg)
5028! PATM - pressure [bar]
5029! QCATM,QVATM - cloud and water vapor mixing ratio
5030! at the first atm. level (kg/kg)
5031! EMISS,RNET - emissivity (0-1) of the ground surface and net
5032! radiation at the surface (W/m^2)
5033! QKMS - exchange coefficient for water vapor in the
5034! surface layer (m/s)
5035! TKMS - exchange coefficient for heat in the surface
5036! layer (m/s)
5037! PC - plant coefficient (resistance)
5038! RHO - density of atmosphere near surface (kg/m^3)
5039! VEGFRAC - greeness fraction (0-1)
5040! CAP - volumetric heat capacity (J/m^3/K)
5041! DRYCAN - dry fraction of vegetated area where
5042! transpiration may take place (0-1)
5043! WETCAN - fraction of vegetated area covered by canopy
5044! water (0-1)
5045! TRANSUM - transpiration function integrated over the
5046! rooting zone (m)
5047! DEW - dew in kg/m^2/s
5048! MAVAIL - fraction of maximum soil moisture in the top
5049! layer (0-1)
5050! ZSMAIN - main levels in soil (m)
5051! ZSHALF - middle of the soil layers (m)
5052! DTDZS - dt/(2.*dzshalf*dzmain)
5053! TBQ - table to define saturated mixing ration
5054! of water vapor for given temperature and pressure
5055! TSO - soil temperature (K)
5056! SOILT - skin temperature (K)
5057!
5058!*********************************************************************
5059
5060 IMPLICIT NONE
5061!---------------------------------------------------------------------
5062!--- input variables
5063
5064 LOGICAL, INTENT(IN ) :: debug_print
5065 INTEGER, INTENT(IN ) :: nroot,ktau,nzs , &
5066 nddzs !nddzs=2*(nzs-2)
5067
5068 INTEGER, INTENT(IN ) :: i,j,iland,isoil,isncond_opt,isncovr_opt
5069 real (kind_phys), INTENT(IN ) :: delt,conflx,prcpms , &
5070 rainf,newsnow,deltsn,snth , &
5071 tabs,transum,snwepr , &
5072 testptlat,testptlon , &
5073 rhonewsn,meltfactor,xlat,xlon,snhei_crit
5074 real :: rhonewcsn
5075
5076!--- 3-D Atmospheric variables
5077 real (kind_phys), &
5078 INTENT(IN ) :: patm, &
5079 qvatm, &
5080 qcatm
5081!--- 2-D variables
5082 real (kind_phys) , &
5083 INTENT(IN ) :: glw, &
5084 gsw, &
5085 rho, &
5086 pc, &
5087 vegfrac, &
5088 qkms, &
5089 tkms
5090
5091!--- soil properties
5092 real (kind_phys) , &
5093 INTENT(IN ) :: &
5094 bclh, &
5095 dqm, &
5096 psis, &
5097 qmin
5098
5099 real (kind_phys), INTENT(IN ) :: cp, &
5100 rovcp, &
5101 cvw, &
5102 stbolt, &
5103 xlvm, &
5104 g0_p
5105
5106
5107 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: zsmain, &
5108 zshalf, &
5109 thdif, &
5110 cap, &
5111 tranf
5112
5113 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: dtdzs
5114
5115 real (kind_phys), DIMENSION(1:5001), INTENT(IN) :: tbq
5116
5117
5118!--- input/output variables
5119!-------- 3-d soil moisture and temperature
5120 real (kind_phys), DIMENSION( 1:nzs ) , &
5121 INTENT(INOUT) :: tso
5122
5123
5124!-------- 2-d variables
5125 real (kind_phys) , &
5126 INTENT(INOUT) :: dew, &
5127 cst, &
5128 rhosn, &
5129 emiss, &
5130 mavail, &
5131 qvg, &
5132 qsg, &
5133 qcg, &
5134 snwe, &
5135 snhei, &
5136 snowfrac, &
5137 smelt, &
5138 snoh, &
5139 snflx, &
5140 s, &
5141 soilt, &
5142 soilt1, &
5143 tsnav
5144
5145 real (kind_phys), INTENT(INOUT) :: drycan, wetcan
5146
5147 real (kind_phys), INTENT(OUT) :: rsm, &
5148 snweprint, &
5149 snheiprint
5150 INTEGER, INTENT(OUT) :: ilnb
5151!--- Local variables
5152
5153
5154 INTEGER :: nzs1,nzs2,k,k1,kn,kk
5155
5156 real (kind_phys) :: x,x1,x2,x4,dzstop,can,ft,sph, &
5157 tn,trans,umveg,denom
5158
5159 real (kind_phys) :: cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn
5160
5161 real (kind_phys) :: t3,upflux,xinet,ras, &
5162 xlmelt,rhocsn,thdifsn, &
5163 beta,epot,xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn
5164
5165 real (kind_phys) :: fso,fsn, &
5166 fkt,d1,d2,d9,d10,did,r211,r21,r22,r6,r7,d11, &
5167 pi,h,fkq,r210,aa,bb,pp,q1,qs1,ts1,tq2,tx2, &
5168 tdenom,c,cc,aa1,rhcs,h1, &
5169 tsob, snprim, sh1, sh2, &
5170 smeltg,snohg,snodif,soh, &
5171 cmc2ms,tnold,qgold,snohgnew
5172
5173 real (kind_phys), DIMENSION(1:NZS) :: transp,cotso,rhtso
5174 real (kind_phys) :: edir1, &
5175 ec1, &
5176 ett1, &
5177 eeta, &
5178 qfx, &
5179 hfx
5180
5181 real (kind_phys) :: rnet,rsmfrac,soiltfrac,hsn,rr,keff,fact
5182 integer :: nmelt, iter
5183
5184!-----------------------------------------------------------------
5185
5186 iter = 0
5187
5188 !-- options for snow conductivity:
5189 !-- 1 - constant
5190 !-- opt 2 - Sturm et al., 1997
5191 keff = 0.265_kind_phys
5192
5193 do k=1,nzs
5194 transp(k)=zero
5195 cotso(k)=zero
5196 rhtso(k)=zero
5197 enddo
5198
5199 IF (debug_print ) THEN
5200print *, 'SNOWTEMP: SNHEI,SNTH,SOILT1: ',snhei,snth,soilt1,soilt
5201 ENDIF
5202 xlmelt=con_hfus
5203 rhocsn=sheatsn* rhosn
5204 rhonewcsn=sheatsn* rhonewsn
5205 if(isncond_opt == 1) then
5206 !-- old version thdifsn = 0.265/RHOCSN
5207 thdifsn = 0.265_kind_phys/rhocsn
5208 else
5209 !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997)
5210 !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652)
5211 fact = one
5212 if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then
5213 keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys
5214 else
5215 keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys
5216 if(debug_print) then
5217 print *,'SnowTemp xlat,xlon,rhosn,keff', xlat,xlon,rhosn,keff,keff/rhocsn*fact
5218 print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn
5219 endif
5220 endif
5221 if ( debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then
5222 print *,'SNOWTEMP - xlat,xlon,newsnow,rhonewsn,rhosn,fact,keff',xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff
5223 endif
5224
5225 if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then
5226 !-- some areas with large snow depth have unrealistically
5227 !-- low snow density (in the Rockie's with snow depth > 1 m).
5228 !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs
5229 !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7
5230 !-- In future a better compaction scheme is needed for these areas.
5231 thdifsn = 4.431718e-7_kind_phys
5232 else
5233 thdifsn = keff/rhocsn * fact
5234 endif
5235 if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then
5236 print *,'SNOWTEMP - thdifsn',xlat,xlon,thdifsn
5237 print *,'SNOWTEMP - 0.265/rhocsn',0.265_kind_phys/rhocsn
5238 endif
5239
5240 endif
5241
5242 ras=rho*1.e-3_kind_phys
5243
5244 soiltfrac=soilt
5245
5246 smelt=zero
5247 soh=zero
5248 smeltg=zero
5249 snohg=zero
5250 snodif=zero
5251 rsm = zero
5252 rsmfrac = zero
5253 fsn=one
5254 fso=zero
5255
5256 nzs1=nzs-1
5257 nzs2=nzs-2
5258
5259 qgold=qvg
5260 dzstop=one/(zsmain(2)-zsmain(1))
5261
5262!******************************************************************************
5263! COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO
5264!******************************************************************************
5265 cotso(1)=zero
5266 rhtso(1)=tso(nzs)
5267 DO 33 k=1,nzs2
5268 kn=nzs-k
5269 k1=2*kn-3
5270 x1=dtdzs(k1)*thdif(kn-1)
5271 x2=dtdzs(k1+1)*thdif(kn)
5272 ft=tso(kn)+x1*(tso(kn-1)-tso(kn)) &
5273 -x2*(tso(kn)-tso(kn+1))
5274 denom=1.+x1+x2-x2*cotso(k)
5275 cotso(k+1)=x1/denom
5276 rhtso(k+1)=(ft+x2*rhtso(k))/denom
5277 33 CONTINUE
5278!--- THE NZS element in COTSO and RHTSO will be for snow
5279!--- There will be 2 layers in snow if it is deeper than DELTSN+SNTH
5280 IF(snhei.GE.snth) then
5281 if(snhei.le.deltsn+snth) then
5282!-- 1-layer snow model
5283 IF (debug_print ) THEN
5284 print *,'1-layer - snth,snhei,deltsn',snth,snhei,deltsn
5285 ENDIF
5286 ilnb=1
5287 snprim=max(snth,snhei)
5288 tsob=tso(1)
5289 soilt1=tso(1)
5290 xsn = delt/2._kind_phys/(zshalf(2)+0.5_kind_phys*snprim)
5291 ddzsn = xsn / snprim
5292 x1sn = ddzsn * thdifsn
5293 x2 = dtdzs(1)*thdif(1)
5294 ft = tso(1)+x1sn*(soilt-tso(1)) &
5295 -x2*(tso(1)-tso(2))
5296 denom = one + x1sn + x2 -x2*cotso(nzs1)
5297 cotso(nzs)=x1sn/denom
5298 rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom
5299 cotsn=cotso(nzs)
5300 rhtsn=rhtso(nzs)
5301!*** Average temperature of snow pack (C)
5302 tsnav=min(zero,0.5_kind_phys*(soilt+tso(1))-tfrz)
5303
5304 else
5305!-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth
5306 IF (debug_print ) THEN
5307 print *,'2-layer - snth,snhei,deltsn',snth,snhei,deltsn
5308 ENDIF
5309 ilnb=2
5310 snprim=deltsn
5311 tsob=soilt1
5312 xsn = delt/2._kind_phys/(0.5_kind_phys*deltsn)
5313 xsn1= delt/2._kind_phys/(zshalf(2)+0.5_kind_phys*(snhei-deltsn))
5314 ddzsn = xsn / deltsn
5315 ddzsn1 = xsn1 / (snhei-deltsn)
5316 x1sn = ddzsn * thdifsn
5317 x1sn1 = ddzsn1 * thdifsn
5318 x2 = dtdzs(1)*thdif(1)
5319 ft = tso(1)+x1sn1*(soilt1-tso(1)) &
5320 -x2*(tso(1)-tso(2))
5321 denom = 1. + x1sn1 + x2 - x2*cotso(nzs1)
5322 cotso(nzs)=x1sn1/denom
5323 rhtso(nzs)=(ft+x2*rhtso(nzs1))/denom
5324 ftsnow = soilt1+x1sn*(soilt-soilt1) &
5325 -x1sn1*(soilt1-tso(1))
5326 denomsn = one + x1sn + x1sn1 - x1sn1*cotso(nzs)
5327 cotsn=x1sn/denomsn
5328 rhtsn=(ftsnow+x1sn1*rhtso(nzs))/denomsn
5329!*** Average temperature of snow pack (C)
5330 tsnav=min(zero,0.5_kind_phys/snhei*((soilt+soilt1)*deltsn &
5331 +(soilt1+tso(1))*(snhei-deltsn)) &
5332 -tfrz)
5333 endif
5334 ENDIF
5335 IF(snhei.LT.snth.AND.snhei.GT.zero) then
5336!--- snow is too thin to be treated separately, therefore it
5337!--- is combined with the first soil layer.
5338 snprim=snhei+zsmain(2)
5339 fsn=snhei/snprim
5340 fso=one-fsn
5341 soilt1=tso(1)
5342 tsob=tso(2)
5343 xsn = delt/2._kind_phys/((zshalf(3)-zsmain(2))+0.5_kind_phys*snprim)
5344 ddzsn = xsn /snprim
5345 x1sn = ddzsn * (fsn*thdifsn+fso*thdif(1))
5346 x2=dtdzs(2)*thdif(2)
5347 ft=tso(2)+x1sn*(soilt-tso(2))- &
5348 x2*(tso(2)-tso(3))
5349 denom = one + x1sn + x2 - x2*cotso(nzs-2)
5350 cotso(nzs1) = x1sn/denom
5351 rhtso(nzs1)=(ft+x2*rhtso(nzs-2))/denom
5352 tsnav=min(zero,0.5_kind_phys*(soilt+tso(1)) &
5353 -tfrz)
5354 cotso(nzs)=cotso(nzs1)
5355 rhtso(nzs)=rhtso(nzs1)
5356 cotsn=cotso(nzs)
5357 rhtsn=rhtso(nzs)
5358
5359 ENDIF
5360
5361!************************************************************************
5362!--- THE HEAT BALANCE EQUATION (Smirnova et al. 1996, EQ. 21,26)
5363!18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes
5364 nmelt=0
5365 snoh=zero
5366
5367 ett1=zero
5368 epot=-qkms*(qvatm-qgold)
5369 rhcs=cap(1)
5370 h=mavail !1.
5371 trans=transum*drycan/zshalf(nroot+1)
5372 can=wetcan+trans
5373 umveg=one-vegfrac
5374 fkt=tkms
5375 d1=cotso(nzs1)
5376 d2=rhtso(nzs1)
5377 tn=soilt
5378 d9=thdif(1)*rhcs*dzstop
5379 d10=tkms*cp*rho
5380 r211=.5_kind_phys*conflx/delt
5381 r21=r211*cp*rho
5382 r22=.5_kind_phys/(thdif(1)*delt*dzstop**2)
5383 r6=emiss *stbolt*.5_kind_phys*tn**4
5384 r7=r6/tn
5385 d11=rnet+r6
5386
5387 IF(snhei.GE.snth) THEN
5388 if(snhei.le.deltsn+snth) then
5389!--- 1-layer snow
5390 d1sn = cotso(nzs)
5391 d2sn = rhtso(nzs)
5392 IF (debug_print ) THEN
5393 print *,'1 layer d1sn,d2sn',i,j,d1sn,d2sn
5394 ENDIF
5395 else
5396!--- 2-layer snow
5397 d1sn = cotsn
5398 d2sn = rhtsn
5399 IF (debug_print ) THEN
5400 print *,'2 layers d1sn,d2sn',i,j,d1sn,d2sn
5401 ENDIF
5402 endif
5403 d9sn= thdifsn*rhocsn / snprim
5404 r22sn = snprim*snprim*0.5_kind_phys/(thdifsn*delt)
5405 IF (debug_print ) THEN
5406 print *,'1 or 2 layers D9sn,R22sn',d9sn,r22sn
5407 ENDIF
5408 ENDIF
5409
5410 IF(snhei.LT.snth.AND.snhei.GT.zero) then
5411!--- thin snow is combined with soil
5412 d1sn = d1
5413 d2sn = d2
5414 d9sn = (fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)/ &
5415 snprim
5416 r22sn = snprim*snprim*0.5_kind_phys &
5417 /((fsn*thdifsn+fso*thdif(1))*delt)
5418 IF (debug_print ) THEN
5419 print *,' Combined D9SN,R22SN,D1SN,D2SN: ',d9sn,r22sn,d1sn,d2sn
5420 ENDIF
5421 ENDIF
5422 IF(snhei.eq.zero)then
5423!--- all snow is sublimated
5424 d9sn = d9
5425 r22sn = r22
5426 d1sn = d1
5427 d2sn = d2
5428 IF (debug_print ) THEN
5429 print *,' SNHEI = 0, D9SN,R22SN,D1SN,D2SN: ',d9sn,r22sn,d1sn,d2sn
5430 ENDIF
5431 ENDIF
5432
5433 2211 continue
5434
5435!18apr08 - the snow melt iteration start point
5436 212 continue
5437
5438!---- TDENOM for snow
5439 tdenom = d9sn*(one-d1sn +r22sn)+d10+r21+r7 &
5440 +rainf*cvw*prcpms &
5441 +rhonewcsn*newsnow/delt
5442
5443 fkq=qkms*rho
5444 r210=r211*rho
5445 c=vegfrac*fkq*can
5446 cc=c*xlvm/tdenom
5447 aa=xlvm*(beta*fkq*umveg+r210)/tdenom
5448 bb=(d10*tabs+r21*tn+xlvm*(qvatm* &
5449 (beta*fkq*umveg+c) &
5450 +r210*qgold)+d11+d9sn*(d2sn+r22sn*tn) &
5451 +rainf*cvw*prcpms*max(tfrz,tabs) &
5452 + rhonewcsn*newsnow/delt*min(tfrz,tabs) &
5453 )/tdenom
5454 aa1=aa+cc
5455 pp=patm*1.e3_kind_phys
5456 aa1=aa1/pp
5457 bb=bb-snoh/tdenom
5458
5459 IF (debug_print ) THEN
5460 if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5461 print *,'1-', i,rnet,tabs,tn,aa1,bb,pp,ktau,newsnow,snwepr,snwe,snhei,snowfrac,soilt,soilt1,tso,rhosn
5462 print *,'2-', i,tdenom,fkq,vegfrac,can,r210,d10,r21,d9sn,d1sn,r22sn,r7,prcpms
5463 endif
5464 ENDIF
5465 CALL vilka(tn,aa1,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil,xlat,xlon)
5466 tq2=qvatm
5467 tx2=tq2*(one-h)
5468 q1=tx2+h*qs1
5469 IF (debug_print ) THEN
5470 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5471 print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',ts1,qs1,tq2,h,tx2,q1,xlat,xlon
5472 ENDIF
5473 IF(q1.LT.qs1) GOTO 100
5474!--- if no saturation - goto 100
5475!--- if saturation - goto 90
5476 90 qvg=qs1
5477 qsg=qs1
5478 qcg=max(zero,q1-qs1)
5479 IF (debug_print ) THEN
5480 print *,'90 QVG,QSG,QCG,TSO(1)',qvg,qsg,qcg,tso(1)
5481 ENDIF
5482 GOTO 200
5483 100 bb=bb-aa*tx2
5484 aa=(aa*h+cc)/pp
5485 CALL vilka(tn,aa,bb,pp,qs1,ts1,tbq,ktau,i,j,iland,isoil,xlat,xlon)
5486 q1=tx2+h*qs1
5487 IF (debug_print ) THEN
5488 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5489 print *,'VILKA2 - TS1,QS1,H,TX2,Q1',ts1,qs1,tq2,h,tx2,q1
5490 ENDIF
5491 IF(q1.GT.qs1) GOTO 90
5492 qsg=qs1
5493 qvg=q1
5494 qcg=zero
5495 IF (debug_print ) THEN
5496 print *,'No Saturation QVG,QSG,QCG,TSO(1)',qvg,qsg,qcg,tso(1)
5497 ENDIF
5498 200 CONTINUE
5499
5500!--- SOILT - skin temperature
5501 soilt=ts1
5502 if(nmelt==1 .and. snowfrac==one .and. snwe > zero .and. soilt > tfrz) then
5503 !--7feb22 on the second iteration when SNOH is known and snwe > 0. after melting,
5504 !-- check if the snow skin temperature is =<tfrzK
5505 !-- when a grid cell is fully covered with snow (snowfrac=1)
5506 !-- or with partial snow cover and snow_mosaic=1 (snowfrac=1).
5507 if (debug_print ) then
5508 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5509 print *,'soilt is too high =',soilt,xlat,xlon
5510 soilt = min(tfrz,soilt)
5511 endif
5512 endif
5513
5514 IF (debug_print ) THEN
5515 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5516 print *,'snwe,snwepr,snhei,snowfr,soilt,soilt1,tso',i,j,snwe,snwepr,snhei,snowfrac,soilt,soilt1,tso
5517 ENDIF
5518! Solution for temperature at 7.5 cm depth and snow-soil interface
5519 IF(snhei.GE.snth) THEN
5520 if(snhei.gt.deltsn+snth) then
5521!-- 2-layer snow model
5522 soilt1=rhtsn+cotsn*soilt
5523 tso(1)=rhtso(nzs)+cotso(nzs)*soilt1
5524 tsob=soilt1
5525 else
5526!-- 1 layer in snow
5527 tso(1)=rhtso(nzs)+cotso(nzs)*soilt
5528 soilt1=tso(1)
5529 tsob=tso(1)
5530 endif
5531 ELSEIF (snhei > zero .and. snhei < snth) THEN
5532! blended
5533 tso(2)=rhtso(nzs1)+cotso(nzs1)*soilt
5534 tso(1)=(tso(2)+(soilt-tso(2))*fso)
5535 soilt1=tso(1)
5536 tsob=tso(2)
5537 ELSE
5538!-- very thin or zero snow. If snow is thin we suppose that
5539!--- tso(i,j,1)=SOILT, and later we recompute tso(i,j,1)
5540 tso(1)=soilt
5541 soilt1=soilt
5542 tsob=tso(1)
5543 ENDIF
5544 if(nmelt==1.and.snowfrac==one) then
5545 !-- second iteration with full snow cover
5546 soilt1= min(tfrz,soilt1)
5547 tso(1)= min(tfrz,tso(1))
5548 tsob = min(tfrz,tsob)
5549 endif
5550
5551!---- Final solution for TSO
5552 IF (snhei > zero .and. snhei < snth) THEN
5553! blended or snow is melted
5554 DO k=3,nzs
5555 kk=nzs-k+1
5556 tso(k)=rhtso(kk)+cotso(kk)*tso(k-1)
5557 END DO
5558
5559 ELSE
5560 DO k=2,nzs
5561 kk=nzs-k+1
5562 tso(k)=rhtso(kk)+cotso(kk)*tso(k-1)
5563 END DO
5564 ENDIF
5565!--- For thin snow layer combined with the top soil layer
5566!--- TSO(1) is recomputed by linear interpolation between SOILT
5567!--- and TSO(i,j,2)
5568! if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then
5569! tso(1)=tso(2)+(soilt-tso(2))*fso
5570! soilt1=tso(1)
5571! tsob = tso(2)
5572! endif
5573
5574
5575 IF (debug_print ) THEN
5576 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5577 print *,'Final SOILT,SOILT1,tso,TSOB,QSG',xlat,xlon,soilt,soilt1,tso,tsob,qsg,'nmelt=',nmelt
5578 print *,'SNWEPR-BETA*EPOT*RAS*DELT',snwepr-beta*epot*ras*delt,beta,snwepr,epot
5579 ENDIF
5580
5581 if(nmelt.eq.1) go to 220
5582
5583!--- IF SOILT > tfrz F then melting of snow can happen
5584! if all snow can evaporate (beta<1), then there is nothing to melt
5585 IF(soilt > tfrz.AND.beta==one.AND.snhei>zero) THEN
5586 !-- snow sublimation and melting
5587 nmelt = 1
5588 soiltfrac=snowfrac*tfrz+(one-snowfrac)*soilt
5589 qsg=min(qsg, qsn(soiltfrac,tbq)/pp)
5590 qvg=snowfrac*qsg+(one-snowfrac)*qvg
5591 t3 = stbolt*tn*tn*tn
5592 upflux = t3 * 0.5_kind_phys*(tn + soiltfrac)
5593 xinet = emiss*(glw-upflux)
5594 epot = -qkms*(qvatm-qsg)
5595 q1=epot*ras
5596
5597
5598 IF (q1.LE.0..or.iter==1) THEN
5599! --- condensation
5600 dew=-epot
5601 DO k=1,nzs
5602 transp(k)=0.
5603 ENDDO
5604
5605 qfx = -xlvm*rho*dew
5606 eeta = qfx/xlvm
5607 ELSE
5608! --- evaporation
5609 DO k=1,nroot
5610 transp(k)=-vegfrac*q1 &
5611 *tranf(k)*drycan/zshalf(nroot+1)
5612 ett1=ett1-transp(k)
5613 ENDDO
5614 DO k=nroot+1,nzs
5615 transp(k)=0.
5616 enddo
5617
5618 edir1 = q1*umveg * beta
5619 ec1 = q1 * wetcan * vegfrac
5620 cmc2ms=cst/delt*ras
5621 eeta = (edir1 + ec1 + ett1)*rhowater
5622! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
5623 qfx= xlvm * eeta
5624 ENDIF
5625
5626 hfx=-d10*(tabs-soiltfrac)
5627
5628 IF(snhei.GE.snth)then
5629 soh=thdifsn*rhocsn*(soiltfrac-tsob)/snprim
5630 snflx=soh
5631 ELSE
5632 soh=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* &
5633 (soiltfrac-tsob)/snprim
5634 snflx=soh
5635 ENDIF
5636
5637!
5638 x= (r21+d9sn*r22sn)*(soiltfrac-tn) + &
5639 xlvm*r210*(qvg-qgold)
5640 IF (debug_print ) THEN
5641 print *,'SNOWTEMP storage ',i,j,x
5642 print *,'R21,D9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim', &
5643 r21,d9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim
5644 ENDIF
5645
5646!-- SNOH is energy flux of snow phase change
5647 snoh=rnet-qfx -hfx - soh - x &
5648 +rhonewcsn*newsnow/delt*(min(tfrz,tabs)-soiltfrac) &
5649 +rainf*cvw*prcpms*(max(tfrz,tabs)-soiltfrac)
5650 snoh=amax1(0.,snoh)
5651!-- SMELT is speed of melting in M/S
5652 smelt= snoh /xlmelt*1.e-3_kind_phys
5653 IF (debug_print ) THEN
5654 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5655 print *,'1- SMELT',smelt,snoh,xlat,xlon
5656 ENDIF
5657
5658 IF(epot.gt.zero .and. snwepr.LE.epot*ras*delt) THEN
5659!-- all snow can evaporate
5660 beta=snwepr/(epot*ras*delt)
5661 smelt=amax1(zero,amin1(smelt,snwepr/delt-beta*epot*ras))
5662 snwe=zero
5663 IF (debug_print ) THEN
5664 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5665 print *,'2- SMELT',xlat,xlon,snwe,smelt,rhonewsn,xlat,xlon
5666 ENDIF
5667 goto 88
5668 ENDIF
5669
5670!18apr08 - Egglston limit
5671 !-- 22apr22 Do not limit snow melting for hail (rhonewsn > 450), or dense snow
5672 !-- (rhosn > 350.) with very warm surface temperatures (>10C)
5673 if( (rhosn < 350._kind_phys .or. (newsnow > zero .and. rhonewsn < 450._kind_phys)) .and. soilt < 283._kind_phys ) then
5674 smelt= amin1(smelt, delt/60._kind_phys*5.6e-8_kind_phys*meltfactor*max(one,(soilt-tfrz)))
5675 IF (debug_print ) THEN
5676 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5677 print *,'3- SMELT',xlat,xlon,smelt,rhosn,rhonewsn,xlat,xlon
5678 ENDIF
5679 endif
5680
5681! rr - potential melting
5682 rr=max(zero,snwepr/delt-beta*epot*ras)
5683 if(smelt > rr) then
5684 smelt = min(smelt,rr)
5685 snwe = zero
5686 IF (debug_print ) THEN
5687 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5688 print *,'4- SMELT i,j,smelt,rr',xlat,xlon,smelt,rr
5689 ENDIF
5690 endif
5691 88 continue
5692 snohgnew=smelt*xlmelt*rhowater
5693 snodif=amax1(zero,(snoh-snohgnew))
5694
5695 snoh=snohgnew
5696 IF (debug_print ) THEN
5697 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5698 print *,'SNOH,SNODIF',snoh,snodif
5699 print *,' xlat, xlon', xlat, xlon
5700 ENDIF
5701
5702 IF( smelt > zero) then
5703!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack
5704 rsmfrac=min(0.18_kind_phys,(max(0.08_kind_phys,snwepr/0.10_kind_phys*0.13_kind_phys)))
5705 if(snhei > 0.01_kind_phys .and. rhosn < 350._kind_phys) then
5706 rsm=min(snwe,rsmfrac*smelt*delt)
5707 else
5708 ! do not keep melted water if snow depth is less that 1 cm
5709 ! or if snow is dense
5710 rsm=zero
5711 endif
5712!18apr08 rsm is part of melted water that stays in snow as liquid
5713 if(rsm > zero) then
5714 smelt=max(zero,smelt-rsm/delt)
5715 IF (debug_print ) THEN
5716 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5717 print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', &
5718 i,j,smelt,rsm,snwepr,rsmfrac
5719 print *,' xlat, xlon', xlat, xlon
5720 ENDIF
5721 endif ! rsm
5722
5723 ENDIF ! smelt > 0
5724
5725!-- update of liquid equivalent of snow depth
5726!-- due to evaporation and snow melt
5727 if(snwe > zero) then
5728 snwe = amax1(zero,(snwepr- &
5729 (smelt+beta*epot*ras)*delt &
5730 ) )
5731 IF (debug_print ) THEN
5732 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5733 print *,' Snow is melting and sublimating, snwe', xlat, xlon, snwe
5734 endif
5735 else
5736 !-- all snow is sublimated or melted
5737 IF (debug_print ) THEN
5738 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5739 print *,' all snwe is sublimated or melted', xlat, xlon, snwe
5740 endif
5741 endif
5742 ELSE
5743 !-- NO MELTING, only sublimation
5744 !--- If there is no snow melting then just evaporation
5745 !--- or condensation changes SNWE
5746 if(snhei.ne.zero .and. beta == one) then
5747 epot=-qkms*(qvatm-qsg)
5748 snwe = amax1(zero,(snwepr- &
5749 beta*epot*ras*delt))
5750 else
5751 !-- all snow is sublibated
5752 snwe = zero
5753 endif
5754
5755 ENDIF
5756
5757!18apr08 - if snow melt occurred then go into iteration for energy budget
5758! solution
5759 if(nmelt.eq.1) goto 212 ! second interation
5760 220 continue
5761
5762 if(smelt > zero .and. rsm > zero) then
5763 if(snwe.le.rsm) then
5764 IF ( debug_print ) THEN
5765 print *,'SNWE<RSM snwe,rsm,smelt*delt,epot*ras*delt,beta', &
5766 snwe,rsm,smelt*delt,epot*ras*delt,beta
5767 ENDIF
5768 else
5769!*** Update snow density on effect of snow melt, melted
5770!*** from the top of the snow. 13% of melted water
5771!*** remains in the pack and changes its density.
5772!*** Eq. 9 (with my correction) in Koren et al. (1999)
5773 xsn=(rhosn*(snwe-rsm)+rhowater*rsm)/ &
5774 snwe
5775 rhosn=min(max(58.8_kind_phys,xsn),500._kind_phys)
5776
5777 rhocsn=sheatsn* rhosn
5778 if(isncond_opt == 1) then
5779 !-- old version thdifsn = 0.265/RHOCSN
5780 thdifsn = 0.265_kind_phys/rhocsn
5781 else
5782 !-- 07Jun19 - thermal conductivity (K_eff) from Sturm et al.(1997)
5783 !-- keff = 10. ** (2.650 * RHOSN*1.e-3 - 1.652)
5784 fact = one
5785 if(rhosn < 156._kind_phys .or. (newsnow > zero .and. rhonewsn < 156._kind_phys)) then
5786 keff = 0.023_kind_phys + 0.234_kind_phys * rhosn * 1.e-3_kind_phys
5787 else
5788 keff = 0.138_kind_phys - 1.01_kind_phys * rhosn*1.e-3_kind_phys + 3.233_kind_phys * rhosn**2 * 1.e-6_kind_phys
5789 if(debug_print) then
5790 print *,'End SNOWTEMP - xlat,xlon,rhosn,keff',xlat,xlon,rhosn,keff
5791 print *,'End SNOWTEMP - 0.265/rhocsn',0.265/rhocsn
5792 endif
5793 endif
5794 if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then
5795 print *,'END SNOWTEMP - newsnow, rhonewsn,rhosn,fact,keff', &
5796 xlat,xlon,newsnow, rhonewsn,rhosn,fact,keff,keff/rhocsn*fact
5797 endif
5798
5799 if(newsnow <= zero .and. snhei > one .and. rhosn > 250._kind_phys) then
5800 !-- some areas with large snow depth have unrealistically
5801 !-- low snow density (in the Rockie's with snow depth > 1 m).
5802 !-- Based on Sturm et al. keff=0.452 typical for hard snow slabs
5803 !-- with rhosn=488 kg/m^3. Thdifsn = 0.452/(2090*488)=4.431718e-7
5804 !-- In future a better compaction scheme is needed for these areas.
5805 thdifsn = 4.431718e-7_kind_phys
5806 else
5807 thdifsn = keff/rhocsn * fact
5808 endif
5809
5810 endif
5811 if (debug_print .and. abs(xlat-testptlat).lt.0.2 .and. abs(xlon-testptlon).lt.0.2) then
5812 print *,'END SNOWTEMP - thdifsn',xlat,xlon,thdifsn
5813 print *,'END SNOWTEMP - 0.265/rhocsn',0.265/rhocsn
5814 endif
5815 endif
5816 endif
5817
5818!--- Compute flux in the top snow layer
5819 IF(snhei.GE.snth)then
5820 s=thdifsn*rhocsn*(soilt-tsob)/snprim
5821 snflx=s
5822 s=d9*(tso(1)-tso(2))
5823 ELSEIF(snhei.lt.snth.and.snhei.GT.zero) then
5824 s=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* &
5825 (soilt-tsob)/snprim
5826 snflx=s
5827 s=d9*(tso(1)-tso(2))
5828 ELSE
5829 s=d9sn*(soilt-tsob)
5830 snflx=s
5831 s=d9*(tso(1)-tso(2))
5832 ENDIF
5833
5834 !-- Update snow depth after melting at the interface with the atmosphere
5835 snhei=snwe * rhowater / rhosn
5836
5837!-- If ground surface temperature
5838!-- is above freezing snow can melt from the bottom at the interface with soild. The following
5839!-- piece of code will check if bottom melting is possible.
5840
5841 IF (debug_print ) THEN
5842 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5843 print *,'snhei,snwe,rhosn,snowfr',snhei,snwe,rhosn,snowfrac,xlat,xlon
5844 endif
5845
5846 IF(tso(1).GT.tfrz .and. snhei > zero) THEN
5847!-- melting at the soil/snow interface
5848 if (snhei.GT.deltsn+snth) then
5849 hsn = snhei - deltsn
5850 IF (debug_print ) THEN
5851 print*,'2 layer snow - snhei,hsn',snhei,hsn
5852 ENDIF
5853 else
5854 IF (debug_print ) THEN
5855 print*,'1 layer snow or blended - snhei',snhei
5856 ENDIF
5857 hsn = snhei
5858 endif
5859
5860 soiltfrac=snowfrac*tfrz+(one-snowfrac)*tso(1)
5861
5862 snohg=(tso(1)-soiltfrac)*(cap(1)*zshalf(2)+ &
5863 rhocsn*0.5_kind_phys*hsn) / delt
5864 snohg=amax1(zero,snohg)
5865 snodif=zero
5866 smeltg=snohg/xlmelt*1.e-3_kind_phys
5867 IF (debug_print ) THEN
5868 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5869 print *,' SMELTG =',smeltg,xlat,xlon
5870 endif
5871! Egglston - empirical limit on snow melt from the bottom of snow pack
5872 !9jun22-- the next line excludeis cases of summer hail from snowmelt limiting
5873 if( (rhosn < 350._kind_phys .or. (newsnow > zero .and. rhonewsn < 450._kind_phys)) .and. soilt < 283._kind_phys ) then
5874 smelt=amin1(smeltg, 5.8e-9_kind_phys)
5875 endif
5876
5877! rr - potential melting
5878 rr=snwe/delt
5879 smeltg=amin1(smeltg, rr)
5880
5881 snohgnew=smeltg*xlmelt*rhowater
5882 snodif=amax1(zero,(snohg-snohgnew))
5883 IF (debug_print ) THEN
5884 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5885 print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',tso(1),soiltfrac,snowfrac,smeltg,snodif
5886 print *,' xlat, xlon', xlat, xlon
5887 ENDIF
5888
5889 snwe=max(zero,snwe-smeltg*delt)
5890 snhei=snwe * rhowater / rhosn
5891 !-- add up all snow melt
5892 smelt = smelt + smeltg
5893
5894 if(snhei > zero) tso(1) = soiltfrac
5895
5896 IF (debug_print ) THEN
5897 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5898 print *,'Melt from the bottom snwe,snhei',snwe,snhei
5899 print *,' xlat, xlon', xlat, xlon
5900 print *,'TSO(1),soiltfrac,snowfrac,smeltg,SNODIF',tso(1),soiltfrac,snowfrac,smeltg,snodif
5901 print *,'Melt from the bottom snwe,snhei,snoh',snwe,snhei,snoh
5902 print *,' Final TSO ',tso
5903 if (snhei==zero) &
5904 print *,'Snow is all melted on the warm ground'
5905 ENDIF
5906
5907 ENDIF ! melt on snow/soil interface
5908
5909 snweprint=snwe
5910 snheiprint=snweprint*rhowater / rhosn
5911
5912 x= (r21+d9sn*r22sn)*(soilt-tn) + &
5913 xlvm*r210*(qsg-qgold)
5914 IF (debug_print ) THEN
5915 !if (abs(xlat-33.35).lt.0.2 .and. abs(xlon-272.55).lt.0.2)then
5916 print *,'end SNOWTEMP storage ',xlat,xlon,x
5917 print *,'R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', &
5918 r21,d9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim
5919 print *,'snwe, snhei ',snwe,snhei
5920 ENDIF
5921
5922 x=x &
5923! "heat" from snow and rain
5924 -rhonewcsn*newsnow/delt*(min(tfrz,tabs)-soilt) &
5925 -rainf*cvw*prcpms*(max(tfrz,tabs)-soilt)
5926 IF (debug_print ) THEN
5927 print *,'x=',x
5928 print *,'SNHEI=',snhei
5929 print *,'SNFLX=',snflx
5930 ENDIF
5931
5932 IF(snhei.GT.zero) THEN
5933 if(ilnb.gt.1) then
5934 tsnav=min(zero,0.5_kind_phys/snhei*((soilt+soilt1)*deltsn &
5935 +(soilt1+tso(1))*(snhei-deltsn)) &
5936 -tfrz)
5937 else
5938 tsnav=min(zero,0.5_kind_phys*(soilt+tso(1)) - tfrz)
5939 endif
5940 ELSE
5941 tsnav= min(zero,soilt - tfrz)
5942 ENDIF
5943
5944!------------------------------------------------------------------------
5945 END SUBROUTINE snowtemp
5946!------------------------------------------------------------------------
5947
5951 SUBROUTINE soilmoist ( debug_print, &
5952 xlat, xlon, testptlat, testptlon, &
5953 DELT,NZS,NDDZS,DTDZS,DTDZS2,RIW, & !--- input parameters
5954 ZSMAIN,ZSHALF,DIFFU,HYDRO, &
5955 QSG,QVG,QCG,QCATM,QVATM,PRCP, &
5956 QKMS,TRANSP,DRIP, &
5957 DEW,SMELT,SOILICE,VEGFRAC,SNOWFRAC,soilres, &
5958 DQM,QMIN,REF,KSAT,RAS,INFMAX, & !--- soil properties
5959 SOILMOIS,SOILIQW,MAVAIL,RUNOFF,RUNOFF2,INFILTRP) !--- output
5960!*************************************************************************
5961! moisture balance equation and Richards eqn.
5962! are solved here
5963!
5964! DELT - time step (s)
5965! IME,JME,NZS - dimensions of soil domain
5966! ZSMAIN - main levels in soil (m)
5967! ZSHALF - middle of the soil layers (m)
5968! DTDZS - dt/(2.*dzshalf*dzmain)
5969! DTDZS2 - dt/(2.*dzshalf)
5970! DIFFU - diffusional conductivity (m^2/s)
5971! HYDRO - hydraulic conductivity (m/s)
5972! QSG,QVG,QCG - saturated mixing ratio, mixing ratio of
5973! water vapor and cloud at the ground
5974! surface, respectively (kg/kg)
5975! QCATM,QVATM - cloud and water vapor mixing ratio
5976! at the first atm. level (kg/kg)
5977! PRCP - precipitation rate in m/s
5978! QKMS - exchange coefficient for water vapor in the
5979! surface layer (m/s)
5980! TRANSP - transpiration from the soil layers (m/s)
5981! DRIP - liquid water dripping from the canopy to soil (m)
5982! DEW - dew in kg/m^2s
5983! SMELT - melting rate in m/s
5984! SOILICE - volumetric content of ice in soil (m^3/m^3)
5985! SOILIQW - volumetric content of liquid water in soil (m^3/m^3)
5986! VEGFRAC - greeness fraction (0-1)
5987! RAS - ration of air density to soil density
5988! INFMAX - maximum infiltration rate (kg/m^2/s)
5989!
5990! SOILMOIS - volumetric soil moisture, 6 levels (m^3/m^3)
5991! MAVAIL - fraction of maximum soil moisture in the top
5992! layer (0-1)
5993! RUNOFF - surface runoff (m/s)
5994! RUNOFF2 - underground runoff (m)
5995! INFILTRP - point infiltration flux into soil (m/s)
5996! /(snow bottom runoff) (mm/s)
5997!
5998! COSMC, RHSMC - coefficients for implicit solution of
5999! Richards equation
6000!******************************************************************
6001 IMPLICIT NONE
6002!------------------------------------------------------------------
6003!--- input variables
6004 LOGICAL, INTENT(IN ) :: debug_print
6005 real (kind_phys), INTENT(IN ) :: delt
6006 real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon
6007 INTEGER, INTENT(IN ) :: nzs,nddzs
6008
6009! input variables
6010
6011 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: zsmain, &
6012 zshalf, &
6013 diffu, &
6014 hydro, &
6015 transp, &
6016 soilice, &
6017 dtdzs2
6018
6019 real (kind_phys), DIMENSION(1:NDDZS), INTENT(IN) :: dtdzs
6020
6021 real (kind_phys), INTENT(IN ) :: qsg,qvg,qcg,qcatm,qvatm, &
6022 qkms,vegfrac,drip,prcp , &
6023 dew,smelt,snowfrac , &
6024 dqm,qmin,ref,ksat,ras,riw,soilres
6025
6026! output
6027
6028 real (kind_phys), DIMENSION( 1:nzs ) , &
6029 INTENT(INOUT) :: soilmois,soiliqw
6030
6031 real (kind_phys), INTENT(INOUT) :: mavail,runoff,runoff2,infiltrp, &
6032 infmax
6033
6034! local variables
6035
6036 real (kind_phys), DIMENSION( 1:nzs ) :: cosmc,rhsmc
6037
6038 real (kind_phys) :: dzs,r1,r2,r3,r4,r5,r6,r7,r8,r9,r10
6039 real (kind_phys) :: refkdt,refdk,delt1,f1max,f2max
6040 real (kind_phys) :: f1,f2,fd,kdt,val,ddt,px,fk,fkmax
6041 real (kind_phys) :: qq,umveg,infmax1,trans
6042 real (kind_phys) :: totliq,flx,flxsat,qtot
6043 real (kind_phys) :: did,x1,x2,x4,denom,q2,q4
6044 real (kind_phys) :: dice,fcr,acrt,frzx,sum,cvfrz
6045
6046 INTEGER :: nzs1,nzs2,k,kk,k1,kn,ialp1,jj,jk
6047
6048!******************************************************************************
6049! COEFFICIENTS FOR THOMAS ALGORITHM FOR SOILMOIS
6050!******************************************************************************
6051 nzs1=nzs-1
6052 nzs2=nzs-2
6053
6054 118 format(6(10pf23.19))
6055
6056 do k=1,nzs
6057 cosmc(k)=zero
6058 rhsmc(k)=zero
6059 enddo
6060
6061 did=(zsmain(nzs)-zshalf(nzs))
6062 x1=zsmain(nzs)-zsmain(nzs1)
6063
6064 denom=(one+diffu(nzs1)/x1/did*delt+hydro(nzs)/(2._kind_phys*did)*delt)
6065 cosmc(1)=delt*(diffu(nzs1)/did/x1 &
6066 +hydro(nzs1)/2._kind_phys/did)/denom
6067 rhsmc(1)=(soilmois(nzs)+transp(nzs)*delt/ &
6068 did)/denom
6069
6070!12 June 2014 - low boundary condition: 1 - zero diffusion below the lowest
6071! level; 2 - soil moisture at the low boundary can be lost due to the root uptake.
6072! So far - no interaction with the water table.
6073
6074 denom=1.+diffu(nzs1)/x1/did*delt
6075 cosmc(1)=delt*(diffu(nzs1)/did/x1 &
6076 +hydro(nzs1)/did)/denom
6077
6078 rhsmc(1)=(soilmois(nzs)-hydro(nzs)*delt/did*soilmois(nzs) &
6079 +transp(nzs)*delt/did)/denom
6080
6081 cosmc(1)=zero
6082 rhsmc(1)=soilmois(nzs)
6083!
6084 DO k=1,nzs2
6085 kn=nzs-k
6086 k1=2*kn-3
6087 x4=2.*dtdzs(k1)*diffu(kn-1)
6088 x2=2.*dtdzs(k1+1)*diffu(kn)
6089 q4=x4+hydro(kn-1)*dtdzs2(kn-1)
6090 q2=x2-hydro(kn+1)*dtdzs2(kn-1)
6091 denom=one+x2+x4-q2*cosmc(k)
6092 cosmc(k+1)=q4/denom
6093 IF (debug_print ) THEN
6094 if (abs(xlat-testptlat).lt.0.05 .and. &
6095 abs(xlon-testptlon).lt.0.05)then
6096 print *,'xlat,xlon=',xlat,xlon
6097 print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' &
6098 ,q2,soilmois(kn),diffu(kn),x2,hydro(kn+1),dtdzs2(kn-1),kn,k
6099 endif
6100 ENDIF
6101 rhsmc(k+1)=(soilmois(kn)+q2*rhsmc(k) &
6102 +transp(kn) &
6103 /(zshalf(kn+1)-zshalf(kn)) &
6104 *delt)/denom
6105 ENDDO
6106
6107! --- MOISTURE BALANCE BEGINS HERE
6108
6109 trans=transp(1)
6110 umveg=(one-vegfrac)*soilres
6111
6112 runoff=zero
6113 runoff2=zero
6114 dzs=zsmain(2)
6115 r1=cosmc(nzs1)
6116 r2= rhsmc(nzs1)
6117 r3=diffu(1)/dzs
6118 r4=r3+hydro(1)*.5_kind_phys
6119 r5=r3-hydro(2)*.5_kind_phys
6120 r6=qkms*ras
6121!-- Total liquid water available on the top of soil domain
6122!-- Without snow - 3 sources of water: precipitation,
6123!-- water dripping from the canopy and dew
6124!-- With snow - only one source of water - snow melt
6125
6126 191 format (f23.19)
6127
6128 totliq=prcp-drip/delt-(one-vegfrac)*dew*ras-smelt
6129 IF (debug_print ) THEN
6130 if (abs(xlat-testptlat).lt.0.05 .and. &
6131 abs(xlon-testptlon).lt.0.05)then
6132 print *,'xlat,xlon=',xlat,xlon
6133 print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', &
6134 umveg*prcp,drip/delt,umveg*dew*ras,smelt
6135 endif
6136 ENDIF
6137
6138 flx=totliq
6139 infiltrp=totliq
6140
6141! ----------- FROZEN GROUND VERSION -------------------------
6142! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF
6143! Areal (kind_phys) DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV.
6144! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT.
6145! BASED ON FIELD DATA CV DEPENDS ON Areal (kind_phys) MEAN OF FROZEN DEPTH, AND IT
6146! CLOSE TO CONSTANT = 0.6 IF Areal (kind_phys) MEAN FROZEN DEPTH IS ABOVE 20 CM.
6147! THAT IS WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6})
6148!
6149! Current logic doesn't allow CVFRZ be bigger than 3
6150 cvfrz = 3._kind_phys
6151
6152!-- SCHAAKE/KOREN EXPRESSION for calculation of max infiltration
6153 refkdt=3._kind_phys
6154 refdk=3.4341e-6_kind_phys
6155 delt1=delt/86400._kind_phys
6156 f1max=dqm*zshalf(2)
6157 f2max=dqm*(zshalf(3)-zshalf(2))
6158 f1=f1max*(one-soilmois(1)/dqm)
6159 dice=soilice(1)*zshalf(2)
6160 fd=f1
6161 do k=2,nzs1
6162 dice=dice+(zshalf(k+1)-zshalf(k))*soilice(k)
6163 fkmax=dqm*(zshalf(k+1)-zshalf(k))
6164 fk=fkmax*(one-soilmois(k)/dqm)
6165 fd=fd+fk
6166 enddo
6167 kdt=refkdt*ksat/refdk
6168 val=(1.-exp(-kdt*delt1))
6169 ddt = fd*val
6170 px= - totliq * delt
6171 IF(px < zero) px = zero
6172 IF(px > zero) THEN
6173 infmax1 = (px*(ddt/(px+ddt)))/delt
6174 ELSE
6175 infmax1 = zero
6176 ENDIF
6177 IF (debug_print ) THEN
6178 print *,'INFMAX1 before frozen part',infmax1
6179 ENDIF
6180
6181! ----------- FROZEN GROUND VERSION --------------------------
6182! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS
6183!
6184! ------------------------------------------------------------------
6185
6186 frzx= 0.15_kind_phys*((dqm+qmin)/ref) * (0.412_kind_phys / 0.468_kind_phys)
6187
6188 fcr = one
6189 IF ( dice .GT. 1.e-2_kind_phys) THEN
6190 acrt = cvfrz * frzx / dice
6191 sum = one
6192 ialp1 = cvfrz - 1
6193 DO jk = 1,ialp1
6194 k = 1
6195 DO jj = jk+1, ialp1
6196 k = k * jj
6197 END DO
6198 sum = sum + (acrt ** ( cvfrz-jk)) / float(k)
6199 END DO
6200 fcr = one - exp(-acrt) * sum
6201 END IF
6202 IF (debug_print ) THEN
6203 print *,'FCR--------',fcr
6204 print *,'DICE=',dice
6205 ENDIF
6206 infmax1 = infmax1* fcr
6207! -------------------------------------------------------------------
6208
6209 infmax = max(infmax1,hydro(1)*soilmois(1))
6210 infmax = min(infmax, -totliq)
6211 IF (debug_print ) THEN
6212 print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', &
6213 infmax,infmax1,hydro(1)*soiliqw(1),-totliq
6214 ENDIF
6215!----
6216 IF (-totliq.GT.infmax)THEN
6217 runoff=-totliq-infmax
6218 flx=-infmax
6219 IF (debug_print ) THEN
6220 print *,'FLX,RUNOFF1=',flx,runoff
6221 ENDIF
6222 ENDIF
6223! INFILTRP is total infiltration flux in M/S
6224 infiltrp=flx
6225! Solution of moisture budget
6226 r7=.5_kind_phys*dzs/delt
6227 r4=r4+r7
6228 flx=flx-soilmois(1)*r7
6229! R8 is for direct evaporation from soil, which occurs
6230! only from snow-free areas
6231 r8=umveg*r6*(one-snowfrac)
6232 qtot=qvatm+qcatm
6233 r9=trans
6234 r10=qtot-qsg
6235
6236!-- evaporation regime
6237 IF(r10.LE.zero) THEN
6238 qq=(r5*r2-flx+r9)/(r4-r5*r1-r10*r8/(ref-qmin))
6239 flxsat=-dqm*(r4-r5*r1-r10*r8/(ref-qmin)) &
6240 +r5*r2+r9
6241 ELSE
6242!-- dew formation regime
6243 qq=(r2*r5-flx+r8*(qtot-qcg-qvg)+r9)/(r4-r1*r5)
6244 flxsat=-dqm*(r4-r1*r5)+r2*r5+r8*(qtot-qvg-qcg)+r9
6245 END IF
6246
6247 IF(qq.LT.0.) THEN
6248! print *,'negative QQ=',qq
6249 soilmois(1)=1.e-8_kind_phys
6250
6251 ELSE IF(qq.GT.dqm) THEN
6252!-- saturation
6253 soilmois(1)=dqm
6254 IF (debug_print ) THEN
6255 print *,'FLXSAT,FLX,DELT',flxsat,flx,delt,runoff2
6256 ENDIF
6257 runoff=runoff+(flxsat-flx)
6258 ELSE
6259 soilmois(1)=min(dqm,max(1.e-8_kind_phys,qq))
6260 END IF
6261
6262 IF (debug_print ) THEN
6263 if (abs(xlat-testptlat).lt.0.05 .and. &
6264 abs(xlon-testptlon).lt.0.05)then
6265 print *,'xlat,xlon=',xlat,xlon
6266 print *,'SOILMOIS,SOILIQW, soilice',soilmois,soiliqw,soilice*riw
6267 print *,'COSMC,RHSMC',cosmc,rhsmc
6268 endif
6269 ENDIF
6270!--- FINAL SOLUTION FOR SOILMOIS
6271! DO K=2,NZS1
6272 DO k=2,nzs
6273 kk=nzs-k+1
6274 qq=cosmc(kk)*soilmois(k-1)+rhsmc(kk)
6275
6276 IF (qq.LT.zero) THEN
6277
6278 ELSE IF(qq.GT.dqm) THEN
6279!-- saturation
6280 soilmois(k)=dqm
6281 IF(k.EQ.nzs)THEN
6282 IF (debug_print ) THEN
6283 print *,'hydro(k),QQ,DQM,k',hydro(k),qq,dqm,k
6284 ENDIF
6285 runoff2=runoff2+((qq-dqm)*(zsmain(k)-zshalf(k)))/delt
6286 ELSE
6287 runoff2=runoff2+((qq-dqm)*(zshalf(k+1)-zshalf(k)))/delt
6288 ENDIF
6289 ELSE
6290 soilmois(k)=min(dqm,max(1.e-8_kind_phys,qq))
6291 END IF
6292 END DO
6293 IF (debug_print ) THEN
6294 if (abs(xlat-testptlat).lt.0.05 .and. &
6295 abs(xlon-testptlon).lt.0.05)then
6296 print *,'xlat,xlon=',xlat,xlon
6297 print *,'END soilmois,soiliqw,soilice',soilmois,soiliqw,soilice*riw
6298 endif
6299 ENDIF
6300
6301 mavail=max(.00001_kind_phys,min(one,(soilmois(1)/(ref-qmin)*(one-snowfrac)+one*snowfrac)))
6302!-------------------------------------------------------------------
6303 END SUBROUTINE soilmoist
6304!-------------------------------------------------------------------
6305
6309 SUBROUTINE soilprop( debug_print, &
6310 xlat, xlon, testptlat, testptlon, &
6311 nzs,fwsat,lwsat,tav,keepfr, & !--- input variables
6312 soilmois,soiliqw,soilice, &
6313 soilmoism,soiliqwm,soilicem, &
6314 QWRTZ,rhocs,dqm,qmin,psis,bclh,ksat, & !--- soil fixed fields
6315 riw,xlmelt,CP,G0_P,cvw,ci, & !--- constants
6316 kqwrtz,kice,kwt, &
6317 thdif,diffu,hydro,cap) !--- output variables
6318
6319!******************************************************************
6320! SOILPROP computes thermal diffusivity, and diffusional and
6321! hydraulic condeuctivities
6322!******************************************************************
6323! NX,NY,NZS - dimensions of soil domain
6324! FWSAT, LWSAT - volumetric content of frozen and liquid water
6325! for saturated condition at given temperatures (m^3/m^3)
6326! TAV - temperature averaged for soil layers (K)
6327! SOILMOIS - volumetric soil moisture at the main soil levels (m^3/m^3)
6328! SOILMOISM - volumetric soil moisture averaged for layers (m^3/m^3)
6329! SOILIQWM - volumetric liquid soil moisture averaged for layers (m^3/m^3)
6330! SOILICEM - volumetric content of soil ice averaged for layers (m^3/m^3)
6331! THDIF - thermal diffusivity for soil layers (W/m/K)
6332! DIFFU - diffusional conductivity (m^2/s)
6333! HYDRO - hydraulic conductivity (m/s)
6334! CAP - volumetric heat capacity (J/m^3/K)
6335!
6336!******************************************************************
6337
6338 IMPLICIT NONE
6339!-----------------------------------------------------------------
6340
6341!--- soil properties
6342 LOGICAL, INTENT(IN ) :: debug_print
6343 INTEGER, INTENT(IN ) :: nzs
6344 real (kind_phys), INTENT(IN ) :: xlat, xlon, testptlat, testptlon
6345
6346 real (kind_phys) , &
6347 INTENT(IN ) :: rhocs, &
6348 bclh, &
6349 dqm, &
6350 ksat, &
6351 psis, &
6352 qwrtz, &
6353 qmin
6354
6355 real (kind_phys), DIMENSION( 1:nzs ) , &
6356 INTENT(IN ) :: soilmois, &
6357 keepfr
6358
6359
6360 real (kind_phys), INTENT(IN ) :: cp, &
6361 cvw, &
6362 riw, &
6363 kqwrtz, &
6364 kice, &
6365 kwt, &
6366 xlmelt, &
6367 g0_p
6368
6369
6370
6371!--- output variables
6372 real (kind_phys), DIMENSION(1:NZS) , &
6373 INTENT(INOUT) :: cap,diffu,hydro , &
6374 thdif,tav , &
6375 soilmoism , &
6376 soiliqw,soilice , &
6377 soilicem,soiliqwm , &
6378 fwsat,lwsat
6379
6380!--- local variables
6381 real (kind_phys), DIMENSION(1:NZS) :: hk,detal,kasat,kjpl
6382
6383 real (kind_phys) :: x,x1,x2,x4,ws,wd,fact,fach,facd,psif,ci
6384 real (kind_phys) :: tln,tavln,tn,pf,a,am,ame,h
6385 INTEGER :: nzs1,k
6386
6387!-- for Johansen thermal conductivity
6388 real (kind_phys) :: kzero,gamd,kdry,kas,x5,sr,ke
6389
6390
6391 nzs1=nzs-1
6392
6393!-- Constants for Johansen (1975) thermal conductivity
6394 kzero =2._kind_phys ! if qwrtz > 0.2
6395
6396
6397 do k=1,nzs
6398 detal(k)=zero
6399 kasat(k)=zero
6400 kjpl(k)=zero
6401 hk(k)=zero
6402 enddo
6403
6404 ws=dqm+qmin
6405 x1=xlmelt/(g0_p*psis)
6406 x2=x1/bclh*ws
6407 x4=(bclh+one)/bclh
6408!--- Next 3 lines are for Johansen thermal conduct.
6409 gamd=(one-ws)*2700._kind_phys
6410 kdry=(0.135_kind_phys*gamd+64.7_kind_phys)/(2700._kind_phys-0.947_kind_phys*gamd)
6411 !-- one more option from Christa's paper
6412 if(qwrtz > 0.2_kind_phys) then
6413 kas=kqwrtz**qwrtz*kzero**(1.-qwrtz)
6414 else
6415 kas=kqwrtz**qwrtz*3._kind_phys**(one-qwrtz)
6416 endif
6417
6418 DO k=1,nzs1
6419 tn=tav(k) - tfrz
6420 wd=ws - riw*soilicem(k)
6421 psif=psis*100._kind_phys*(wd/(soiliqwm(k)+qmin))**bclh &
6422 * (ws/wd)**3._kind_phys
6423!--- PSIF should be in [CM] to compute PF
6424 pf=log10(abs(psif))
6425 fact=one+riw*soilicem(k)
6426!--- HK is for McCumber thermal conductivity
6427 IF(pf.LE.5.2_kind_phys) THEN
6428 hk(k)=420._kind_phys*exp(-(pf+2.7_kind_phys))*fact
6429 ELSE
6430 hk(k)=.1744_kind_phys*fact
6431 END IF
6432
6433 IF(soilicem(k).NE.zero.AND.tn.LT.zero) then
6434!--- DETAL is taking care of energy spent on freezing or released from
6435! melting of soil water
6436
6437 detal(k)=tfrz*x2/(tav(k)*tav(k))* &
6438 (tav(k)/(x1*tn))**x4
6439
6440 if(keepfr(k).eq.one) then
6441 detal(k)=zero
6442 endif
6443
6444 ENDIF
6445
6446!--- Next 10 lines calculate Johansen thermal conductivity KJPL
6447 kasat(k)=kas**(one-ws)*kice**fwsat(k) &
6448 *kwt**lwsat(k)
6449
6450 x5=(soilmoism(k)+qmin)/ws
6451 if(soilicem(k).eq.zero) then
6452 sr=max(0.101_kind_phys,x5)
6453 ke=log10(sr)+one
6454 else
6455 ke=x5
6456 endif
6457
6458 kjpl(k)=ke*(kasat(k)-kdry)+kdry
6459
6460!--- CAP -volumetric heat capacity
6461 cap(k)=(one-ws)*rhocs &
6462 + (soiliqwm(k)+qmin)*cvw &
6463 + soilicem(k)*ci &
6464 + (dqm-soilmoism(k))*cp*1.2_kind_phys &
6465 - detal(k)*rhowater*xlmelt
6466
6467 a=riw*soilicem(k)
6468
6469 if((ws-a).lt.0.12_kind_phys)then
6470 diffu(k)=zero
6471 else
6472 h=max(zero,(soilmoism(k)+qmin-a)/(max(1.e-8_kind_phys,(ws-a))))
6473 facd=one
6474 if(a.ne.zero)facd=one-a/max(1.e-8_kind_phys,soilmoism(k))
6475 ame=max(1.e-8_kind_phys,ws-riw*soilicem(k))
6476!--- DIFFU is diffusional conductivity of soil water
6477 diffu(k)=-bclh*ksat*psis/ame* &
6478 (ws/ame)**3._kind_phys &
6479 *h**(bclh+2._kind_phys)*facd
6480 endif
6481
6482!--- thdif - thermal diffusivity
6483! thdif(K)=HK(K)/CAP(K)
6484!--- Use thermal conductivity from Johansen (1975)
6485 thdif(k)=kjpl(k)/cap(k)
6486
6487 END DO
6488
6489 IF (debug_print ) THEN
6490 print *,'soilice*riw,soiliqw,soilmois,ws',soilice*riw,soiliqw,soilmois,ws
6491 ENDIF
6492 DO k=1,nzs
6493
6494 if((ws-riw*soilice(k)).lt.0.12_kind_phys)then
6495 hydro(k)=zero
6496 else
6497 fach=one
6498 if(soilice(k).ne.zero) &
6499 fach=one-riw*soilice(k)/max(1.e-8_kind_phys,soilmois(k))
6500 am=max(1.e-8_kind_phys,ws-riw*soilice(k))
6501!--- HYDRO is hydraulic conductivity of soil water
6502 hydro(k)=min(ksat,ksat/am* &
6503 (soiliqw(k)/am) &
6504 **(2._kind_phys*bclh+2._kind_phys) &
6505 * fach)
6506 if(hydro(k)<1.e-10_kind_phys)hydro(k)=zero
6507 endif
6508
6509 ENDDO
6510 IF (debug_print ) THEN
6511 print *,'hydro=',hydro
6512 ENDIF
6513
6514!-----------------------------------------------------------------------
6515 END SUBROUTINE soilprop
6516!-----------------------------------------------------------------------
6517
6521 SUBROUTINE transf( debug_print, &
6522 xlat,xlon,testptlat,testptlon, &
6523 nzs,nroot,soiliqw,tabs,lai,gswin, & !--- input variables
6524 dqm,qmin,ref,wilt,zshalf,pc,iland, & !--- soil fixed fields
6525 tranf,transum) !--- output variables
6526
6527!-------------------------------------------------------------------
6528!--- TRANF(K) - THE TRANSPIRATION FUNCTION (Smirnova et al. 1996, EQ. 18,19)
6529!*******************************************************************
6530! NX,NY,NZS - dimensions of soil domain
6531! SOILIQW - volumetric liquid soil moisture at the main levels (m^3/m^3)
6532! TRANF - the transpiration function at levels (m)
6533! TRANSUM - transpiration function integrated over the rooting zone (m)
6534!
6535!*******************************************************************
6536 IMPLICIT NONE
6537!-------------------------------------------------------------------
6538
6539!--- input variables
6540
6541 LOGICAL, INTENT(IN ) :: debug_print
6542 INTEGER, INTENT(IN ) :: nroot,nzs,iland
6543 real (kind_phys), INTENT(IN ) :: xlat,xlon,testptlat,testptlon
6544
6545 real (kind_phys) , &
6546 INTENT(IN ) :: gswin, tabs, lai
6547!--- soil properties
6548 real (kind_phys) , &
6549 INTENT(IN ) :: dqm, &
6550 qmin, &
6551 ref, &
6552 pc, &
6553 wilt
6554
6555 real (kind_phys), DIMENSION(1:NZS), INTENT(IN) :: soiliqw, &
6556 zshalf
6557
6558!-- output
6559 real (kind_phys), DIMENSION(1:NZS), INTENT(OUT) :: tranf
6560 real (kind_phys), INTENT(OUT) :: transum
6561
6562!-- local variables
6563 real (kind_phys) :: totliq, did
6564 INTEGER :: k
6565
6566!-- for non-linear root distribution
6567 real (kind_phys) :: gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4
6568 real (kind_phys) :: ftem, pctot, fsol, f1, cmin, cmax, totcnd
6569 real (kind_phys), DIMENSION(1:NZS) :: part
6570!--------------------------------------------------------------------
6571
6572 do k=1,nzs
6573 part(k)=zero
6574 tranf(k)=zero
6575 enddo
6576
6577 transum=zero
6578 totliq=soiliqw(1)+qmin
6579 sm1=totliq
6580 sm2=sm1*sm1
6581 sm3=sm2*sm1
6582 sm4=sm3*sm1
6583 ap0=0.299_kind_phys
6584 ap1=-8.152_kind_phys
6585 ap2=61.653_kind_phys
6586 ap3=-115.876_kind_phys
6587 ap4=59.656_kind_phys
6588 gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4
6589 if(totliq.ge.ref) gx=one
6590 if(totliq.le.wilt) gx=zero
6591 if(gx.gt.one) gx=one
6592 if(gx.lt.zero) gx=zero
6593 did=zshalf(2)
6594 part(1)=did*gx
6595 IF(totliq.GT.ref) THEN
6596 tranf(1)=did
6597 ELSE IF(totliq.LE.wilt) THEN
6598 tranf(1)=zero
6599 ELSE
6600 tranf(1)=(totliq-wilt)/(ref-wilt)*did
6601 ENDIF
6602!-- uncomment next line for non-linear root distribution
6603 !TRANF(1)=part(1)
6604
6605 DO k=2,nroot
6606 totliq=soiliqw(k)+qmin
6607 sm1=totliq
6608 sm2=sm1*sm1
6609 sm3=sm2*sm1
6610 sm4=sm3*sm1
6611 gx=ap0+ap1*sm1+ap2*sm2+ap3*sm3+ap4*sm4
6612 if(totliq.ge.ref) gx=one
6613 if(totliq.le.wilt) gx=zero
6614 if(gx.gt.one) gx=one
6615 if(gx.lt.zero) gx=zero
6616 did=zshalf(k+1)-zshalf(k)
6617 part(k)=did*gx
6618 IF(totliq.GE.ref) THEN
6619 tranf(k)=did
6620 ELSE IF(totliq.LE.wilt) THEN
6621 tranf(k)=zero
6622 ELSE
6623 tranf(k)=(totliq-wilt) &
6624 /(ref-wilt)*did
6625 ENDIF
6626!-- uncomment next line for non-linear root distribution
6627 !TRANF(k)=part(k)
6628 END DO
6629 IF (debug_print ) THEN
6630 if (abs(xlat-testptlat).lt.0.05 .and. &
6631 abs(xlon-testptlon).lt.0.05)then
6632 print *,'xlat,xlon=',xlat,xlon
6633 print *,'soiliqw =',soiliqw,'wilt=',wilt,'qmin= ',qmin
6634 print *,'tranf = ',tranf
6635 endif
6636 ENDIF
6637
6638! For LAI> 3 => transpiration at potential rate (F.Tardieu, 2013)
6639 if(lai > 4._kind_phys) then
6640 pctot=0.8_kind_phys
6641 else
6642 pctot=pc
6643!- 26aug16- next 2 lines could lead to LH increase and higher 2-m Q during the day
6644! pctot=min(0.8,pc*lai)
6645! pctot=min(0.8,max(pc,pc*lai))
6646 endif
6647 IF ( debug_print ) THEN
6648 if (abs(xlat-testptlat).lt.0.05 .and. &
6649 abs(xlon-testptlon).lt.0.05)then
6650 print *,'xlat,xlon=',xlat,xlon
6651 print *,'pctot,lai,pc',pctot,lai,pc
6652 endif
6653 ENDIF
6654!---
6655!--- air temperature function
6656! Avissar (1985) and AX 7/95
6657 IF (tabs .LE. 302.15_kind_phys) THEN
6658 ftem = one / (one + exp(-0.41_kind_phys * (tabs - 282.05_kind_phys)))
6659 ELSE
6660 ftem = one / (one + exp(0.5_kind_phys * (tabs - 314.0_kind_phys)))
6661 ENDIF
6662!--- incoming solar function
6663 cmin = one/rsmax_data
6664 cmax = one/rstbl(iland)
6665 if(lai > one) then
6666 cmax = lai/rstbl(iland) ! max conductance
6667 endif
6668! Noihlan & Planton (1988)
6669 f1=zero
6670! if(lai > 0.01) then
6671! f1 = 1.1/lai*gswin/rgltbl(iland)! f1=0. when GSWin=0.
6672! fsol = (f1+cmin/cmax)/(1.+f1)
6673! fsol=min(1.,fsol)
6674! else
6675! fsol=cmin/cmax
6676! endif
6677! totcnd = max(lai/rstbl(iland), pctot * ftem * f1)
6678! Mahrer & Avissar (1982), Avissar et al. (1985)
6679 if (gswin < rgltbl(iland)) then
6680 fsol = one / (one + exp(-0.034_kind_phys * (gswin - 3.5_kind_phys)))
6681 else
6682 fsol = one
6683 endif
6684!--- total conductance
6685 totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax
6686
6687 IF ( debug_print ) THEN
6688 if (abs(xlat-testptlat).lt.0.05 .and. &
6689 abs(xlon-testptlon).lt.0.05)then
6690 print *,'xlat,xlon=',xlat,xlon
6691 print *,'GSWin,Tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol',gswin,tabs,lai,f1,cmax,cmin,pc,pctot,ftem,fsol
6692 print *,'iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd' &
6693 ,iland,rgltbl(iland),rstbl(iland),rsmax_data,totcnd
6694 endif
6695 ENDIF
6696
6697!-- TRANSUM - total for the rooting zone
6698 transum=zero
6699 DO k=1,nroot
6700! linear root distribution
6701 tranf(k)=max(zero,tranf(k)*totcnd)
6702 transum=transum+tranf(k)
6703 END DO
6704 IF ( debug_print ) THEN
6705 if (abs(xlat-testptlat).lt.0.05 .and. &
6706 abs(xlon-testptlon).lt.0.05)then
6707 print *,'xlat,xlon=',xlat,xlon
6708 print *,'transum,TRANF',transum,tranf
6709 endif
6710 ENDIF
6711
6712!-----------------------------------------------------------------
6713 END SUBROUTINE transf
6714!-----------------------------------------------------------------
6715
6720 SUBROUTINE vilka(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil,xlat,xlon)
6721!--------------------------------------------------------------
6722!--- VILKA finds the solution of energy budget at the surface
6723!--- using table T,QS computed from Clausius-Klapeiron
6724!--------------------------------------------------------------
6725 real (kind_phys), DIMENSION(1:5001), INTENT(IN ) :: tt
6726 real (kind_phys), INTENT(IN ) :: tn,d1,d2,pp,xlat,xlon
6727 INTEGER, INTENT(IN ) :: nstep,ii,j,iland,isoil
6728
6729 real (kind_phys), INTENT(OUT ) :: qs, ts
6730
6731 real (kind_phys) :: f1,t1,t2,rn
6732 INTEGER :: i,i1
6733
6734 i=(tn-1.7315e2_kind_dbl_prec)/.05_kind_dbl_prec+1
6735 t1=173.1_kind_dbl_prec+float(i)*.05_kind_dbl_prec
6736 f1=t1+d1*tt(i)-d2
6737 i1=i-f1/(.05_kind_dbl_prec+d1*(tt(i+1)-tt(i)))
6738 i=i1
6739 IF(i.GT.5000.OR.i.LT.1) GOTO 1
6740 10 i1=i
6741 t1=173.1_kind_dbl_prec+float(i)*.05_kind_dbl_prec
6742 f1=t1+d1*tt(i)-d2
6743 rn=f1/(.05_kind_dbl_prec+d1*(tt(i+1)-tt(i)))
6744 i=i-int(rn)
6745 IF(i.GT.5000.OR.i.LT.1) GOTO 1
6746 IF(i1.NE.i) GOTO 10
6747 ts=t1-.05_kind_dbl_prec*rn
6748 qs=(tt(i)+(tt(i)-tt(i+1))*rn)/pp
6749 GOTO 20
6750 1 print *,' AVOST IN VILKA Table index= ',i
6751 print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn
6752 print *,'AVOST point at xlat/xlon=',xlat,xlon
6753 20 CONTINUE
6754!-----------------------------------------------------------------------
6755 END SUBROUTINE vilka
6756!-----------------------------------------------------------------------
6757
6762 SUBROUTINE soilvegin ( debug_print,mosaic_lu,mosaic_soil, &
6763 soilfrac,nscat,shdmin, shdmax, &
6764 NLCAT,IVGTYP,ISLTYP,iswater,MYJ, &
6765 IFOREST,lufrac,vegfrac,EMISS,PC, &
6766 MSNF,FACSNF,ZNT,LAI,RDLAI2D, &
6767 QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J, &
6768 errmsg, errflg)
6769
6770!************************************************************************
6771! Set-up soil and vegetation Parameters in the case when
6772! snow disappears during the forecast and snow parameters
6773! shold be replaced by surface parameters according to
6774! soil and vegetation types in this point.
6775!
6776! Output:
6777!
6778!
6779! Soil parameters:
6780! DQM: MAX soil moisture content - MIN (m^3/m^3)
6781! REF: Reference soil moisture (m^3/m^3)
6782! WILT: Wilting PT soil moisture contents (m^3/m^3)
6783! QMIN: Air dry soil moist content limits (m^3/m^3)
6784! PSIS: SAT soil potential coefs. (m)
6785! KSAT: SAT soil diffusivity/conductivity coefs. (m/s)
6786! BCLH: Soil diffusivity/conductivity exponent.
6787!
6788! ************************************************************************
6789
6790 IMPLICIT NONE
6791!---------------------------------------------------------------------------
6792 integer, parameter :: nsoilclas=19
6793 integer, parameter :: nvegclas=24+3
6794 integer, parameter :: ilsnow=99
6795
6796 LOGICAL, INTENT(IN ) :: debug_print
6797 INTEGER, INTENT(IN ) :: mosaic_lu, mosaic_soil
6798 INTEGER, INTENT(IN ) :: nlcat, nscat, iswater, i, j
6799
6800!--- soiltyp classification according to STATSGO(nclasses=16)
6801!
6802! 1 SAND SAND
6803! 2 LOAMY SAND LOAMY SAND
6804! 3 SANDY LOAM SANDY LOAM
6805! 4 SILT LOAM SILTY LOAM
6806! 5 SILT SILTY LOAM
6807! 6 LOAM LOAM
6808! 7 SANDY CLAY LOAM SANDY CLAY LOAM
6809! 8 SILTY CLAY LOAM SILTY CLAY LOAM
6810! 9 CLAY LOAM CLAY LOAM
6811! 10 SANDY CLAY SANDY CLAY
6812! 11 SILTY CLAY SILTY CLAY
6813! 12 CLAY LIGHT CLAY
6814! 13 ORGANIC MATERIALS LOAM
6815! 14 WATER
6816! 15 BEDROCK
6817! Bedrock is reclassified as class 14
6818! 16 OTHER (land-ice)
6819! 17 Playa
6820! 18 Lava
6821! 19 White Sand
6822!
6823!----------------------------------------------------------------------
6824 real (kind_phys) lqma(nsoilclas),lrhc(nsoilclas), &
6825 lpsi(nsoilclas),lqmi(nsoilclas), &
6826 lbcl(nsoilclas),lkas(nsoilclas), &
6827 lwil(nsoilclas),lref(nsoilclas), &
6828 datqtz(nsoilclas)
6829!-- LQMA Rawls et al.[1982]
6830! DATA LQMA /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398,
6831! & 0.471, 0.464, 0.430, 0.479, 0.475, 0.439, 1.0, 0.20, 0.401/
6832!---
6833!-- Clapp, R. and G. Hornberger, 1978: Empirical equations for some soil
6834! hydraulic properties, Water Resour. Res., 14, 601-604.
6835
6836!-- Clapp et al. [1978]
6837 DATA lqma /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, &
6838 0.477, 0.476, 0.426, 0.492, 0.482, 0.451, 1.0, &
6839 0.20, 0.435, 0.468, 0.200, 0.339/
6840
6841!-- LREF Rawls et al.[1982]
6842! DATA LREF /0.091, 0.125, 0.207, 0.330, 0.360, 0.270, 0.255,
6843! & 0.366, 0.318, 0.339, 0.387, 0.396, 0.329, 1.0, 0.108, 0.283/
6844
6845!-- Clapp et al. [1978]
6846 DATA lref /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, &
6847 0.357, 0.391, 0.316, 0.409, 0.400, 0.314, 1., &
6848 0.1, 0.249, 0.454, 0.17, 0.236/
6849
6850!-- LWIL Rawls et al.[1982]
6851! DATA LWIL/0.033, 0.055, 0.095, 0.133, 0.133, 0.117, 0.148,
6852! & 0.208, 0.197, 0.239, 0.250, 0.272, 0.066, 0.0, 0.006, 0.029/
6853
6854!-- Clapp et al. [1978]
6855 DATA lwil/0.068, 0.075, 0.114, 0.179, 0.179, 0.155, 0.175, &
6856 0.218, 0.250, 0.219, 0.283, 0.286, 0.155, 0.0, &
6857 0.006, 0.114, 0.030, 0.006, 0.01/
6858
6859! DATA LQMI/0.010, 0.028, 0.047, 0.084, 0.084, 0.066, 0.067,
6860! & 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.0, 0.006, 0.028/
6861
6862!-- Carsel and Parrish [1988]
6863 DATA lqmi/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, &
6864 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, &
6865 0.004, 0.065, 0.020, 0.004, 0.008/
6866
6867!-- LPSI Cosby et al[1984]
6868! DATA LPSI/0.060, 0.036, 0.141, 0.759, 0.759, 0.355, 0.135,
6869! & 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.0, 0.069, 0.036/
6870! & 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.0, 0.069, 0.036/
6871
6872!-- Clapp et al. [1978]
6873 DATA lpsi/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, &
6874 0.356, 0.630, 0.153, 0.490, 0.405, 0.478, 0.0, &
6875 0.121, 0.218, 0.468, 0.069, 0.069/
6876
6877!-- LKAS Rawls et al.[1982]
6878! DATA LKAS/5.83E-5, 1.70E-5, 7.19E-6, 1.89E-6, 1.89E-6,
6879! & 3.67E-6, 1.19E-6, 4.17E-7, 6.39E-7, 3.33E-7, 2.50E-7,
6880! & 1.67E-7, 3.38E-6, 0.0, 1.41E-4, 1.41E-5/
6881
6882!-- Clapp et al. [1978]
6883 DATA lkas/1.76e-4, 1.56e-4, 3.47e-5, 7.20e-6, 7.20e-6, &
6884 6.95e-6, 6.30e-6, 1.70e-6, 2.45e-6, 2.17e-6, &
6885 1.03e-6, 1.28e-6, 6.95e-6, 0.0, 1.41e-4, &
6886 3.47e-5, 1.28e-6, 1.41e-4, 1.76e-4/
6887
6888!-- LBCL Cosby et al [1984]
6889! DATA LBCL/2.79, 4.26, 4.74, 5.33, 5.33, 5.25, 6.66,
6890! & 8.72, 8.17, 10.73, 10.39, 11.55, 5.25, 0.0, 2.79, 4.26/
6891
6892!-- Clapp et al. [1978]
6893 DATA lbcl/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, 7.12, &
6894 7.75, 8.52, 10.40, 10.40, 11.40, 5.39, 0.0, &
6895 4.05, 4.90, 11.55, 2.79, 2.79/
6896
6897 DATA lrhc /1.47,1.41,1.34,1.27,1.27,1.21,1.18,1.32,1.23, &
6898 1.18,1.15,1.09,1.21,4.18,2.03,2.10,1.09,2.03,1.47/
6899
6900 DATA datqtz/0.92,0.82,0.60,0.25,0.10,0.40,0.60,0.10,0.35, &
6901 0.52,0.10,0.25,0.00,0.,0.60,0.0,0.25,0.60,0.92/
6902
6903!--------------------------------------------------------------------------
6904!
6905! USGS Vegetation Types
6906!
6907! 1: Urban and Built-Up Land
6908! 2: Dryland Cropland and Pasture
6909! 3: Irrigated Cropland and Pasture
6910! 4: Mixed Dryland/Irrigated Cropland and Pasture
6911! 5: Cropland/Grassland Mosaic
6912! 6: Cropland/Woodland Mosaic
6913! 7: Grassland
6914! 8: Shrubland
6915! 9: Mixed Shrubland/Grassland
6916! 10: Savanna
6917! 11: Deciduous Broadleaf Forest
6918! 12: Deciduous Needleleaf Forest
6919! 13: Evergreen Broadleaf Forest
6920! 14: Evergreen Needleleaf Fores
6921! 15: Mixed Forest
6922! 16: Water Bodies
6923! 17: Herbaceous Wetland
6924! 18: Wooded Wetland
6925! 19: Barren or Sparsely Vegetated
6926! 20: Herbaceous Tundra
6927! 21: Wooded Tundra
6928! 22: Mixed Tundra
6929! 23: Bare Ground Tundra
6930! 24: Snow or Ice
6931!
6932! 25: Playa
6933! 26: Lava
6934! 27: White Sand
6935
6936! MODIS vegetation categories from VEGPARM.TBL
6937! 1: Evergreen Needleleaf Forest
6938! 2: Evergreen Broadleaf Forest
6939! 3: Deciduous Needleleaf Forest
6940! 4: Deciduous Broadleaf Forest
6941! 5: Mixed Forests
6942! 6: Closed Shrublands
6943! 7: Open Shrublands
6944! 8: Woody Savannas
6945! 9: Savannas
6946! 10: Grasslands
6947! 11: Permanent wetlands
6948! 12: Croplands
6949! 13: Urban and Built-Up
6950! 14: cropland/natural vegetation mosaic
6951! 15: Snow and Ice
6952! 16: Barren or Sparsely Vegetated
6953! 17: Water
6954! 18: Wooded Tundra
6955! 19: Mixed Tundra
6956! 20: Barren Tundra
6957! 21: Lakes
6958
6959
6960!---- Below are the arrays for the vegetation parameters
6961 real (kind_phys) lalb(nvegclas),lmoi(nvegclas),lemi(nvegclas), &
6962 lrou(nvegclas),lthi(nvegclas),lsig(nvegclas), &
6963 lpc(nvegclas)
6964
6965!************************************************************************
6966!---- vegetation parameters
6967!
6968!-- USGS model
6969!
6970 DATA lalb/.18,.17,.18,.18,.18,.16,.19,.22,.20,.20,.16,.14, &
6971 .12,.12,.13,.08,.14,.14,.25,.15,.15,.15,.25,.55, &
6972 .30,.16,.60 /
6973 DATA lemi/.88,4*.92,.93,.92,.88,.9,.92,.93,.94, &
6974 .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95, &
6975 .85,.85,.90 /
6976!-- Roughness length is changed for forests and some others
6977 DATA lrou/.5,.06,.075,.065,.05,.2,.075,.1,.11,.15,.5,.5, &
6978 .5,.5,.5,.0001,.2,.4,.05,.1,.15,.1,.065,.05, &
6979 .01,.15,.01 /
6980
6981 DATA lmoi/.1,.3,.5,.25,.25,.35,.15,.1,.15,.15,.3,.3, &
6982 .5,.3,.3,1.,.6,.35,.02,.5,.5,.5,.02,.95,.40,.50,.40/
6983!
6984!---- still needs to be corrected
6985!
6986 DATA lpc /0.4,0.3,0.4,0.4,0.4,0.4,0.4,0.4,0.4,0.4,5*0.55,0.,0.55,0.55, &
6987 0.3,0.3,0.4,0.4,0.3,0.,.3,0.,0./
6988!***************************************************************************
6989
6990
6991 INTEGER :: &
6992 ivgtyp, &
6993 isltyp
6994
6995 LOGICAL, INTENT(IN ) :: myj
6996 real (kind_phys), INTENT(IN ) :: shdmax
6997 real (kind_phys), INTENT(IN ) :: shdmin
6998 real (kind_phys), INTENT(IN ) :: vegfrac
6999 real (kind_phys), DIMENSION( 1:NLCAT ), INTENT(IN):: lufrac
7000 real (kind_phys), DIMENSION( 1:NSCAT ), INTENT(IN):: soilfrac
7001
7002 real (kind_phys) , &
7003 INTENT ( OUT) :: pc, &
7004 msnf, &
7005 facsnf
7006
7007 real (kind_phys) , &
7008 INTENT (INOUT ) :: emiss, &
7009 lai, &
7010 znt
7011 LOGICAL, intent(in) :: rdlai2d
7012!--- soil properties
7013 real (kind_phys) , &
7014 INTENT( OUT) :: rhocs, &
7015 bclh, &
7016 dqm, &
7017 ksat, &
7018 psis, &
7019 qmin, &
7020 qwrtz, &
7021 ref, &
7022 wilt
7023 INTEGER, INTENT ( OUT) :: iforest
7024 character(len=*),intent(out) :: errmsg
7025 integer, intent(out) :: errflg
7026 INTEGER :: kstart, kfin, lstart, lfin
7027 INTEGER :: k
7028 real (kind_phys) :: area, factor, znt1, lb
7029 real (kind_phys), DIMENSION( 1:NLCAT ) :: znttoday, laitoday, deltalai
7030
7031!***********************************************************************
7032! DATA ZS1/0.0,0.05,0.20,0.40,1.6,3.0/ ! o - levels in soil
7033! DATA ZS2/0.0,0.025,0.125,0.30,1.,2.3/ ! x - levels in soil
7034
7035
7036 ! Initialize error-handling
7037 errflg = 0
7038 errmsg = ''
7039
7040 iforest = ifortbl(ivgtyp)
7041
7042 IF (debug_print ) THEN
7043 print *,'ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp)', &
7044 ifortbl(ivgtyp),ivgtyp,laitbl(ivgtyp),z0tbl(ivgtyp)
7045 ENDIF
7046
7047 deltalai(:) = zero
7048
7049! 11oct2012 - seasonal correction on ZNT for crops and LAI for all veg. types
7050! factor = 1 with minimum greenness --> vegfrac = shdmin (cold season)
7051! factor = 0 with maximum greenness --> vegfrac = shdmax
7052! SHDMAX, SHDMIN and VEGFRAC are in % here.
7053 if((shdmax - shdmin) .lt. one) then
7054 factor = one ! min greenness
7055 else
7056 factor = one - max(zero,min(one,(vegfrac - shdmin)/max(one,(shdmax-shdmin))))
7057 endif
7058
7059! 18sept18 - LAITBL and Z0TBL are the max values
7060 do k = 1,nlcat
7061 if(ifortbl(k) == 1) deltalai(k)=min(0.2_kind_phys,0.8_kind_phys*laitbl(k))
7062 if(ifortbl(k) == 2 .or. ifortbl(k) == 7) deltalai(k)=min(0.5_kind_phys,0.8_kind_phys*laitbl(k))
7063 if(ifortbl(k) == 3) deltalai(k)=min(0.45_kind_phys,0.8_kind_phys*laitbl(k))
7064 if(ifortbl(k) == 4) deltalai(k)=min(0.75_kind_phys,0.8_kind_phys*laitbl(k))
7065 if(ifortbl(k) == 5) deltalai(k)=min(0.86_kind_phys,0.8_kind_phys*laitbl(k))
7066
7067 if(k.ne.iswater) then
7068!-- 20aug18 - change in LAItoday based on the greenness fraction for the current day
7069 laitoday(k) = laitbl(k) - deltalai(k) * factor
7070
7071 if(ifortbl(k) == 7) then
7072!-- seasonal change of roughness length for crops
7073 znttoday(k) = z0tbl(k) - 0.125_kind_phys * factor
7074 else
7075 znttoday(k) = z0tbl(k)
7076 endif
7077 else
7078 laitoday(k) = laitbl(k)
7079 znttoday(k) = znt ! do not overwrite z0 over water with the table value
7080 endif
7081 enddo
7082
7083 IF (debug_print ) THEN
7084 print *,'ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai,laitoday(ivgtyp),znttoday(ivgtyp)', &
7085 i,j,ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai(ivgtyp),laitoday(ivgtyp),znttoday(ivgtyp)
7086 ENDIF
7087
7088 emiss = zero
7089 znt = zero
7090 znt1 = zero
7091 pc = zero
7092 msnf = zero
7093 facsnf= zero
7094 if(.not.rdlai2d) lai = zero
7095 area = zero
7096!-- mosaic approach to landuse in the grid box
7097! Use Mason (1988) Eq.(15) to compute effective ZNT;
7098! Lb - blending height = L/200., where L is the length scale
7099! of regions with varying Z0 (Lb = 5 if L=1000 m)
7100 lb = 5._kind_phys
7101 if(mosaic_lu == 1) then
7102 do k = 1,nlcat
7103 area = area + lufrac(k)
7104 emiss = emiss+ lemitbl(k)*lufrac(k)
7105 znt = znt + lufrac(k)/alog(lb/znttoday(k))**2._kind_phys
7106! ZNT1 - weighted average in the grid box, not used, computed for comparison
7107 znt1 = znt1 + lufrac(k)*znttoday(k)
7108 if(.not.rdlai2d) lai = lai + laitoday(k)*lufrac(k)
7109 pc = pc + pctbl(k)*lufrac(k)
7110 msnf = msnf + mfsno(k)*lufrac(k)
7111 facsnf= facsnf + sncovfac(k)*lufrac(k)
7112 enddo
7113
7114 if (area.gt.one) area=one
7115 if (area <= zero) then
7116 print *,'Bad area of grid box', area
7117 errflg = 1
7118 errmsg = 'ERROR(SOILVEGIN): Bad area of grid box'
7119 return
7120 endif
7121
7122 IF (debug_print ) THEN
7123 print *,'area=',area,i,j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),emiss,znt,znt1,lai,pc
7124 ENDIF
7125
7126 emiss = emiss/area
7127 znt1 = znt1/area
7128 znt = lb/exp(sqrt(one/znt))
7129 if(.not.rdlai2d) lai = lai/area
7130 pc = pc /area
7131 msnf = msnf /area
7132 facsnf= facsnf /area
7133
7134 IF (debug_print ) THEN
7135 print *,'mosaic=',j,ivgtyp,nlcat,(lufrac(k),k=1,nlcat),emiss,znt,znt1,lai,pc
7136 ENDIF
7137
7138
7139 else
7140 emiss = lemitbl(ivgtyp)
7141 znt = znttoday(ivgtyp)
7142 pc = pctbl(ivgtyp)
7143 msnf = mfsno(ivgtyp)
7144 facsnf= sncovfac(ivgtyp)
7145 if(.not.rdlai2d) lai = laitoday(ivgtyp)
7146 endif
7147
7148! parameters from SOILPARM.TBL
7149 rhocs = zero
7150 bclh = zero
7151 dqm = zero
7152 ksat = zero
7153 psis = zero
7154 qmin = zero
7155 ref = zero
7156 wilt = zero
7157 qwrtz = zero
7158 area = zero
7159! mosaic approach
7160 if(mosaic_soil == 1 ) then
7161 do k = 1, nscat
7162 if(k.ne.14) then ! STATSGO value for water
7163 !exclude water points from this loop
7164 area = area + soilfrac(k)
7165 rhocs = rhocs + hc(k)*1.e6_kind_phys*soilfrac(k)
7166 bclh = bclh + bb(k)*soilfrac(k)
7167 dqm = dqm + (maxsmc(k)- &
7168 drysmc(k))*soilfrac(k)
7169 ksat = ksat + satdk(k)*soilfrac(k)
7170 psis = psis - satpsi(k)*soilfrac(k)
7171 qmin = qmin + drysmc(k)*soilfrac(k)
7172 ref = ref + refsmc(k)*soilfrac(k)
7173 wilt = wilt + wltsmc(k)*soilfrac(k)
7174 qwrtz = qwrtz + qtz(k)*soilfrac(k)
7175 endif
7176 enddo
7177 if (area.gt.one) area=one
7178 if (area <= zero) then
7179! area = 0. for water points
7180! print *,'Area of a grid box', area, 'iswater = ',iswater
7181 rhocs = hc(isltyp)*1.e6_kind_phys
7182 bclh = bb(isltyp)
7183 dqm = maxsmc(isltyp)- &
7184 drysmc(isltyp)
7185 ksat = satdk(isltyp)
7186 psis = - satpsi(isltyp)
7187 qmin = drysmc(isltyp)
7188 ref = refsmc(isltyp)
7189 wilt = wltsmc(isltyp)
7190 qwrtz = qtz(isltyp)
7191 else
7192 rhocs = rhocs/area
7193 bclh = bclh/area
7194 dqm = dqm/area
7195 ksat = ksat/area
7196 psis = psis/area
7197 qmin = qmin/area
7198 ref = ref/area
7199 wilt = wilt/area
7200 qwrtz = qwrtz/area
7201 endif
7202
7203! dominant category approach
7204 else
7205 if(isltyp.ne.14) then
7206 rhocs = hc(isltyp)*1.e6_kind_phys
7207 bclh = bb(isltyp)
7208 dqm = maxsmc(isltyp)- &
7209 drysmc(isltyp)
7210 ksat = satdk(isltyp)
7211 psis = - satpsi(isltyp)
7212 qmin = drysmc(isltyp)
7213 ref = refsmc(isltyp)
7214 wilt = wltsmc(isltyp)
7215 qwrtz = qtz(isltyp)
7216 endif
7217 endif
7218
7219!--------------------------------------------------------------------------
7220 END SUBROUTINE soilvegin
7221!--------------------------------------------------------------------------
7222
7227 SUBROUTINE ruclsminit( debug_print, landfrac, fice, min_seaice, &
7228 nzs, isltyp, ivgtyp, mavail, &
7229 sh2o, smfr3d, tslb, smois, &
7230 ims,ime, jms,jme, kms,kme, &
7231 its,ite, jts,jte, kts,kte )
7232
7233 use namelist_soilveg_ruc
7234
7235#if ( WRF_CHEM == 1 )
7236 USE module_data_gocart_dust
7237#endif
7238 IMPLICIT NONE
7239 LOGICAL, INTENT(IN ) :: debug_print
7240 real (kind_phys), DIMENSION( ims:ime), INTENT(IN ) :: landfrac, fice
7241 real (kind_phys), INTENT(IN ) :: min_seaice
7242
7243 INTEGER, INTENT(IN ) :: &
7244 ims,ime, jms,jme, kms,kme, &
7245 its,ite, jts,jte, kts,kte, &
7246 nzs
7247
7248 real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , &
7249 INTENT(IN) :: tslb, &
7250 smois
7251
7252 INTEGER, DIMENSION( ims:ime, jms:jme ) , &
7253 INTENT(INOUT) :: isltyp,ivgtyp
7254
7255 real (kind_phys), DIMENSION( ims:ime, 1:nzs, jms:jme ) , &
7256 INTENT(OUT) :: smfr3d, &
7257 sh2o
7258
7259 real (kind_phys), DIMENSION( ims:ime, jms:jme ) , &
7260 INTENT(OUT) :: mavail
7261
7262 !-- local
7263 real (kind_phys), DIMENSION ( 1:nzs ) :: soiliqw
7264
7265 INTEGER :: i,j,l,itf,jtf
7266 real (kind_phys) :: riw,xlmelt,tln,dqm,ref,psis,qmin,bclh
7267
7268 INTEGER :: errflag
7269
7270 riw=rhoice*1.e-3_kind_phys
7271 xlmelt=con_hfus
7272
7273! for FIM
7274 itf=ite ! min0(ite,ide-1)
7275 jtf=jte ! min0(jte,jde-1)
7276
7277 errflag = 0
7278 DO j = jts,jtf
7279 DO i = its,itf
7280
7281 IF ( isltyp( i,j ) .LT. 0 ) THEN
7282 errflag = 1
7283 print *, &
7284 "module_sf_ruclsm.F: lsminit: out of range ISLTYP ",i,j,isltyp( i,j )
7285 ENDIF
7286 ENDDO
7287 ENDDO
7288 IF ( errflag .EQ. 1 ) THEN
7289 print *,&
7290 "module_sf_ruclsm.F: lsminit: out of range value "// &
7291 "of ISLTYP. Is this field in the input?"
7292 ENDIF
7293
7294 DO j=jts,jtf
7295 DO i=its,itf
7296
7297 ! in Zobler classification isltyp=0 for water. Statsgo classification
7298 ! has isltyp=14 for water
7299 if (isltyp(i,j) == 0) isltyp(i,j)=14
7300
7301 if(landfrac(i) > zero ) then
7302 !-- land
7303 !-- Computate volumetric content of ice in soil
7304 !-- and initialize MAVAIL
7305 dqm = maxsmc(isltyp(i,j)) - &
7306 drysmc(isltyp(i,j))
7307 ref = refsmc(isltyp(i,j))
7308 psis = - satpsi(isltyp(i,j))
7309 qmin = drysmc(isltyp(i,j))
7310 bclh = bb(isltyp(i,j))
7311
7312 mavail(i,j) = max(0.00001_kind_phys,min(one,(smois(i,1,j)-qmin)/(ref-qmin)))
7313
7314 DO l=1,nzs
7315 !-- for land points initialize soil ice
7316 tln=log(tslb(i,l,j)/tfrz)
7317
7318 if(tln.lt.zero) then
7319 soiliqw(l)=(dqm+qmin)*(xlmelt* &
7320 (tslb(i,l,j)-tfrz)/tslb(i,l,j)/grav/psis) &
7321 **(-one/bclh)
7322 soiliqw(l)=max(zero,soiliqw(l))
7323 soiliqw(l)=min(soiliqw(l),smois(i,l,j))
7324 sh2o(i,l,j)=soiliqw(l)
7325 smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/riw
7326
7327 else
7328 smfr3d(i,l,j)=zero
7329 sh2o(i,l,j)=smois(i,l,j)
7330 endif
7331 ENDDO
7332
7333 elseif( fice(i) > min_seaice) then
7334 !-- ice
7335 mavail(i,j) = one
7336 DO l=1,nzs
7337 smfr3d(i,l,j)=one
7338 sh2o(i,l,j)=zero
7339 ENDDO
7340
7341 else
7342 !-- water ISLTYP=14
7343 mavail(i,j) = one
7344 DO l=1,nzs
7345 smfr3d(i,l,j)=zero
7346 sh2o(i,l,j)=one
7347 ENDDO
7348
7349 endif ! land
7350
7351 ENDDO
7352 ENDDO
7353
7354
7355 END SUBROUTINE ruclsminit
7356!
7357!-----------------------------------------------------------------
7360 SUBROUTINE ruclsm_soilvegparm( debug_print,MMINLURUC, MMINSL)
7361!-----------------------------------------------------------------
7362
7363 IMPLICIT NONE
7364 LOGICAL, INTENT(IN ) :: debug_print
7365
7366 integer :: lumatch, iindex, lc, num_slope
7367 integer :: ierr
7368 INTEGER , PARAMETER :: open_ok = 0
7369
7370 character*8 :: mminluruc, mminsl
7371 character*128 :: vege_parm_string
7372! logical, external :: wrf_dm_on_monitor
7373
7374
7375!-----SPECIFY VEGETATION RELATED CHARACTERISTICS :
7376! ALBBCK: SFC albedo (in percentage)
7377! Z0: Roughness length (m)
7378! LEMI: Emissivity
7379! PC: Plant coefficient for transpiration function
7380! -- the rest of the parameters are read in but not used currently
7381! SHDFAC: Green vegetation fraction (in percentage)
7382! Note: The ALBEDO, Z0, and SHDFAC values read from the following table
7383! ALBEDO, amd Z0 are specified in LAND-USE TABLE; and SHDFAC is
7384! the monthly green vegetation data
7385! CMXTBL: MAX CNPY Capacity (m)
7386! RSMIN: Mimimum stomatal resistance (s m-1)
7387! RSMAX: Max. stomatal resistance (s m-1)
7388! RGL: Parameters used in radiation stress function
7389! HS: Parameter used in vapor pressure deficit functio
7390! TOPT: Optimum transpiration air temperature. (K)
7391! CMCMAX: Maximum canopy water capacity
7392! CFACTR: Parameter used in the canopy inteception calculati
7393! SNUP: Threshold snow depth (in water equivalent m) that
7394! implies 100% snow cover
7395! LAI: Leaf area index (dimensionless)
7396! MAXALB: Upper bound on maximum albedo over deep snow
7397!
7398!-----READ IN VEGETAION PROPERTIES FROM VEGPARM.TBL
7399!
7400
7401! IF ( wrf_dm_on_monitor() ) THEN
7402
7403 OPEN(19, file='VEGPARM.TBL',form='FORMATTED',status='OLD',iostat=ierr)
7404 IF(ierr .NE. open_ok ) THEN
7405 print *,&
7406 'module_sf_ruclsm.F: soil_veg_gen_parm: failure opening VEGPARM.TBL'
7407 END IF
7408
7409 print *,&
7410 'INPUT VEGPARM FOR ',mminluruc
7411
7412 lumatch=0
7413
7414 2000 FORMAT (a8)
7415!sms$serial begin
7416 READ (19,'(A)') vege_parm_string
7417!sms$serial end
7418 outer : DO
7419!sms$serial begin
7420 READ (19,2000,END=2002)lutype
7421 READ (19,*)lucats,iindex
7422!sms$serial end
7423
7424 print *,&
7425 'VEGPARM FOR ',lutype,' FOUND', lucats,' CATEGORIES'
7426
7427 IF(lutype.NE.mminluruc)THEN ! Skip over the undesired table
7428 print *,&
7429 'Skipping ', lutype, ' table'
7430 DO lc=1,lucats
7431!sms$serial begin
7432 READ (19,*)
7433!sms$serial end
7434 ENDDO
7435 inner : DO ! Find the next "Vegetation Parameters"
7436!sms$serial begin
7437 READ (19,'(A)',END=2002) vege_parm_string
7438!sms$serial end
7439 IF (trim(vege_parm_string) .EQ. "Vegetation Parameters") THEN
7440 EXIT inner
7441 END IF
7442 ENDDO inner
7443 ELSE
7444 lumatch=1
7445 print *,&
7446 'Found ', lutype, ' table'
7447 EXIT outer ! Found the table, read the data
7448 END IF
7449
7450 ENDDO outer
7451
7452 IF (lumatch == 1) then
7453 print *,&
7454 'Reading ',lutype,' table'
7455 DO lc=1,lucats
7456!sms$serial begin
7457 READ (19,*)iindex,albtbl(lc),z0tbl(lc),lemitbl(lc),pctbl(lc), &
7458 shdtbl(lc),ifortbl(lc),rstbl(lc),rgltbl(lc), &
7459 hstbl(lc),snuptbl(lc),laitbl(lc),maxalb(lc)
7460!sms$serial end
7461 ENDDO
7462!
7463!sms$serial begin
7464 READ (19,*)
7465 READ (19,*)topt_data
7466 READ (19,*)
7467 READ (19,*)cmcmax_data
7468 READ (19,*)
7469 READ (19,*)cfactr_data
7470 READ (19,*)
7471 READ (19,*)rsmax_data
7472 READ (19,*)
7473 READ (19,*)bare
7474 READ (19,*)
7475 READ (19,*)glacier
7476 READ (19,*)
7477 READ (19,*)natural
7478 READ (19,*)
7479 READ (19,*)crop
7480 READ (19,*)
7481 READ (19,*,iostat=ierr)urban
7482!sms$serial end
7483 if ( ierr /= 0 ) print *, "-------- VEGPARM.TBL READ ERROR --------"
7484 if ( ierr /= 0 ) print *, "Problem read URBAN from VEGPARM.TBL"
7485 if ( ierr /= 0 ) print *, " -- Use updated version of VEGPARM.TBL "
7486 if ( ierr /= 0 ) print *, "Problem read URBAN from VEGPARM.TBL"
7487
7488 ENDIF
7489
7490 2002 CONTINUE
7491 CLOSE (19)
7492!-----
7493 IF (debug_print ) THEN
7494 print *,' LEMITBL, PCTBL, Z0TBL, LAITBL --->', lemitbl, pctbl, z0tbl, laitbl
7495 ENDIF
7496
7497
7498 IF (lumatch == 0) then
7499! CALL wrf_error_fatal ("Land Use Dataset '"//MMINLURUC//"' not found in VEGPARM.TBL.")
7500 ENDIF
7501
7502!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL
7503!
7504! IF ( wrf_dm_on_monitor() ) THEN
7505 OPEN(19, file='SOILPARM.TBL',form='FORMATTED',status='OLD',iostat=ierr)
7506 IF(ierr .NE. open_ok ) THEN
7507 print *,&
7508 'module_sf_ruclsm.F: soil_veg_gen_parm: failure opening SOILPARM.TBL'
7509 END IF
7510
7511 print *,'INPUT SOIL TEXTURE CLASSIFICATION = ',mminsl
7512
7513 lumatch=0
7514
7515!sms$serial begin
7516 READ (19,'(A)') vege_parm_string
7517!sms$serial end
7518 outersl : DO
7519!sms$serial begin
7520 READ (19,2000,END=2003)sltype
7521 READ (19,*)slcats,iindex
7522!sms$serial end
7523
7524 print *,&
7525 'SOILPARM FOR ',sltype,' FOUND', slcats,' CATEGORIES'
7526
7527 IF(sltype.NE.mminsl)THEN ! Skip over the undesired table
7528 print *,&
7529 'Skipping ', sltype, ' table'
7530 DO lc=1,slcats
7531!sms$serial begin
7532 READ (19,*)
7533!sms$serial end
7534 ENDDO
7535 innersl : DO ! Find the next "Vegetation Parameters"
7536!sms$serial begin
7537 READ (19,'(A)',END=2002) vege_parm_string
7538!sms$serial end
7539 IF (trim(vege_parm_string) .EQ. "Soil Parameters") THEN
7540 EXIT innersl
7541 END IF
7542 ENDDO innersl
7543 ELSE
7544 lumatch=1
7545 print *,&
7546 'Found ', sltype, ' table'
7547 EXIT outersl ! Found the table, read the data
7548 END IF
7549
7550 ENDDO outersl
7551
7552 IF (lumatch == 1) then
7553 print *,'SLCATS=',slcats
7554 DO lc=1,slcats
7555!sms$serial begin
7556 READ (19,*) iindex,bb(lc),drysmc(lc),hc(lc),maxsmc(lc),&
7557 refsmc(lc),satpsi(lc),satdk(lc), satdw(lc), &
7558 wltsmc(lc), qtz(lc)
7559 !sms$serial end
7560 ENDDO
7561 ENDIF
7562
7563 2003 CONTINUE
7564
7565 CLOSE (19)
7566
7567 IF(lumatch.EQ.0)THEN
7568 print *, 'SOIl TEXTURE IN INPUT FILE DOES NOT '
7569 print *, 'MATCH SOILPARM TABLE'
7570 print *, 'INCONSISTENT OR MISSING SOILPARM FILE'
7571 ENDIF
7572
7573!
7574!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL
7575!
7576 OPEN(19, file='GENPARM.TBL',form='FORMATTED',status='OLD',iostat=ierr)
7577 IF(ierr .NE. open_ok ) THEN
7578 print *,&
7579 'module_sf_ruclsm.F: soil_veg_gen_parm: failure opening GENPARM.TBL'
7580 END IF
7581
7582!sms$serial begin
7583 READ (19,*)
7584 READ (19,*)
7585 READ (19,*) num_slope
7586!sms$serial end
7587
7588 slpcats=num_slope
7589
7590 DO lc=1,slpcats
7591!sms$serial begin
7592 READ (19,*)slope_data(lc)
7593!sms$serial end
7594 ENDDO
7595
7596!sms$serial begin
7597 READ (19,*)
7598 READ (19,*)sbeta_data
7599 READ (19,*)
7600 READ (19,*)fxexp_data
7601 READ (19,*)
7602 READ (19,*)csoil_data
7603 READ (19,*)
7604 READ (19,*)salp_data
7605 READ (19,*)
7606 READ (19,*)refdk_data
7607 READ (19,*)
7608 READ (19,*)refkdt_data
7609 READ (19,*)
7610 READ (19,*)frzk_data
7611 READ (19,*)
7612 READ (19,*)zbot_data
7613 READ (19,*)
7614 READ (19,*)czil_data
7615 READ (19,*)
7616 READ (19,*)smlow_data
7617 READ (19,*)
7618 READ (19,*)smhigh_data
7619!sms$serial end
7620 CLOSE (19)
7621
7622!-----------------------------------------------------------------
7623 END SUBROUTINE ruclsm_soilvegparm
7624!-----------------------------------------------------------------
7625
7629 SUBROUTINE soilin (ISLTYP, DQM, REF, PSIS, QMIN, BCLH )
7630
7631!--- soiltyp classification according to STATSGO(nclasses=16)
7632!
7633! 1 SAND SAND
7634! 2 LOAMY SAND LOAMY SAND
7635! 3 SANDY LOAM SANDY LOAM
7636! 4 SILT LOAM SILTY LOAM
7637! 5 SILT SILTY LOAM
7638! 6 LOAM LOAM
7639! 7 SANDY CLAY LOAM SANDY CLAY LOAM
7640! 8 SILTY CLAY LOAM SILTY CLAY LOAM
7641! 9 CLAY LOAM CLAY LOAM
7642! 10 SANDY CLAY SANDY CLAY
7643! 11 SILTY CLAY SILTY CLAY
7644! 12 CLAY LIGHT CLAY
7645! 13 ORGANIC MATERIALS LOAM
7646! 14 WATER
7647! 15 BEDROCK
7648! Bedrock is reclassified as class 14
7649! 16 OTHER (land-ice)
7650! extra classes from Fei Chen
7651! 17 Playa
7652! 18 Lava
7653! 19 White Sand
7654!
7655!----------------------------------------------------------------------
7656 integer, parameter :: nsoilclas=19
7657
7658 integer, intent ( in) :: isltyp
7659 real, intent ( out) :: dqm,ref,qmin,psis,bclh
7660
7661 real (kind_phys) lqma(nsoilclas),lref(nsoilclas),lbcl(nsoilclas), &
7662 lpsi(nsoilclas),lqmi(nsoilclas)
7663
7664!-- LQMA Rawls et al.[1982]
7665! DATA LQMA /0.417, 0.437, 0.453, 0.501, 0.486, 0.463, 0.398,
7666! & 0.471, 0.464, 0.430, 0.479, 0.475, 0.439, 1.0, 0.20, 0.401/
7667!---
7668!-- Clapp, R. and G. Hornberger, Empirical equations for some soil
7669! hydraulic properties, Water Resour. Res., 14,601-604,1978.
7670!-- Clapp et al. [1978]
7671 DATA lqma /0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, &
7672 0.477, 0.476, 0.426, 0.492, 0.482, 0.451, 1.0, &
7673 0.20, 0.435, 0.468, 0.200, 0.339/
7674
7675!-- Clapp et al. [1978]
7676 DATA lref /0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, &
7677 0.357, 0.391, 0.316, 0.409, 0.400, 0.314, 1., &
7678 0.1, 0.249, 0.454, 0.17, 0.236/
7679
7680!-- Carsel and Parrish [1988]
7681 DATA lqmi/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, &
7682 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, &
7683 0.004, 0.065, 0.020, 0.004, 0.008/
7684
7685!-- Clapp et al. [1978]
7686 DATA lpsi/0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, &
7687 0.356, 0.630, 0.153, 0.490, 0.405, 0.478, 0.0, &
7688 0.121, 0.218, 0.468, 0.069, 0.069/
7689
7690!-- Clapp et al. [1978]
7691 DATA lbcl/4.05, 4.38, 4.90, 5.30, 5.30, 5.39, 7.12, &
7692 7.75, 8.52, 10.40, 10.40, 11.40, 5.39, 0.0, &
7693 4.05, 4.90, 11.55, 2.79, 2.79/
7694
7695
7696 dqm = lqma(isltyp)- &
7697 lqmi(isltyp)
7698 ref = lref(isltyp)
7699 psis = - lpsi(isltyp)
7700 qmin = lqmi(isltyp)
7701 bclh = lbcl(isltyp)
7702
7703 END SUBROUTINE soilin
7704
7705!+---+-----------------------------------------------------------------+
7709 real (kind_phys) function rslf(p,t)
7710
7711 IMPLICIT NONE
7712 real (kind_phys), INTENT(IN):: p, t
7713 real (kind_phys):: esl,x
7714 real (kind_phys), PARAMETER:: c0= .611583699e03
7715 real (kind_phys), PARAMETER:: c1= .444606896e02
7716 real (kind_phys), PARAMETER:: c2= .143177157e01
7717 real (kind_phys), PARAMETER:: c3= .264224321e-1
7718 real (kind_phys), PARAMETER:: c4= .299291081e-3
7719 real (kind_phys), PARAMETER:: c5= .203154182e-5
7720 real (kind_phys), PARAMETER:: c6= .702620698e-8
7721 real (kind_phys), PARAMETER:: c7= .379534310e-11
7722 real (kind_phys), PARAMETER:: c8=-.321582393e-13
7723
7724 x=max(-80._kind_dbl_prec,t-273.16_kind_dbl_prec)
7725
7726 esl=c0+x*(c1+x*(c2+x*(c3+x*(c4+x*(c5+x*(c6+x*(c7+x*c8)))))))
7727 esl=min(esl, p*0.15_kind_dbl_prec) ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres.
7728 rslf=.622_kind_dbl_prec*esl/max(1.e-4_kind_dbl_prec,(p-esl))
7729
7730 END FUNCTION rslf
7731
7732
7733END MODULE module_sf_ruclsm
module_sf_ruclsm::ruclsminit
subroutine, public ruclsminit(debug_print, landfrac, fice, min_seaice, nzs, isltyp, ivgtyp, mavail, sh2o, smfr3d, tslb, smois, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
This subroutine computes liquid and forezen soil moisture from the total soil moisture,...
Definition module_sf_ruclsm.F90:7232
module_sf_ruclsm::rslf
real(kind_phys) function, public rslf(p, t)
This function calculates the liquid saturation vapor mixing ratio as a function of temperature and pr...
Definition module_sf_ruclsm.F90:7710
module_sf_ruclsm::lsmruc
subroutine, public lsmruc(xlat, xlon, dt, init, lsm_cold_start, ktau, iter, nsl, graupelncv, snowncv, rainncv, raincv, zs, rainbl, snow, snowh, snowc, frzfrac, frpcpn, rhosnf, precipfr, exticeden, hgt, stdev, z3d, p8w, t3d, qv3d, qc3d, rho3d, emisbck, glw, gswdn, gsw, emiss, chklowq, chs, flqc, flhc, rhonewsn_ex, mosaic_lu, mosaic_soil, isncond_opt, isncovr_opt, mavail, canwat, vegfra, alb, znt, z0, snoalb, albbck, lai, landusef, nlcat, soilctop, nscat, smcwlt, smcref, qsfc, qsg, qvg, qcg, dew, soilt1, tsnav, tbot, ivgtyp, isltyp, xland, iswater, isice, xice, xice_threshold, cp, rv, rd, g0, pi, lv, stbolt, soilmois, sh2o, smavail, smmax, tso, soilt, edir, ec, ett, sublim, snoh, hfx, qfx, lh, infiltr, runoff1, runoff2, acrunoff, sfcexc, sfcevp, grdflx, snowfallac, acsnow, snom, smfr3d, keepfr3dflag, add_fire_heat_flux, fire_heat_flux, myj, shdmin, shdmax, rdlai2d, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte, errmsg, errflg)
The RUN LSM model is described in Smirnova et al.(1997) and Smirnova et al.(2000) .
Definition module_sf_ruclsm.F90:116
module_sf_ruclsm
This module contains the entity of the RUC LSM model, which is a soil/veg/snowpack and ice/snowpack...
Definition module_sf_ruclsm.F90:9
namelist_soilveg_ruc
This module contains the namelist options of soil/vegetation in RUC.
Definition namelist_soilveg_ruc.F90:4
sflx
This module contains the entity of GFS Noah LSM Model(Version 2.7).
Definition sflx.f:5