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