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